********************************************************************************
       TITL 'CONTROL BLOCK 0'
 
CNS    EQU  >7016             * GROM ADDRESS'S
PWRZZ  EQU  >7492             *
LOGZZ  EQU  >76C2             *
EXPZZ  EQU  >75CA             *
SQRZZ  EQU  >783A             *
COSZZ  EQU  >78B2             *
SINZZ  EQU  >78C0             *
TANZZ  EQU  >7940             *
ATNZZ  EQU  >797C             *
GRINT  EQU  >79EC             *
ROLOUT EQU  >7A90             *
ROLIN  EQU  >7AC4             *
CRUNCH EQU  >7B88             *
PUTCHR EQU  >7F6E             *
*
* NOTE RXB CHANGE: All lables with $ changed to Z
*      LPAR$ is now LPARZ or WARN$$ is now WARNZZ
*      this was to use same names as GPL source 
*
********************************************************************************
       TITL 'EQUATES'
 
*
LWCNS  EQU  >6000
*
WRVDP  EQU  >4000             Write enable for VDP
XVDPRD EQU  >8800             Read VDP data
XVDPWD EQU  >8C00             Write VDP data
XGRMRD EQU  >9800             Read GROM data
GRMWAX EQU  >9C02->9800       Write GROM address
GRMRAX EQU  >9802->9800       Read GROM address
GRMWDX EQU  >9C00->9800       GROM write data
*
KEYTAB EQU  >CB00             ADDRESS OF KEYWORD TABLE
*
NEGPAD EQU  >7D00
PAD0   EQU  >8300
PAD1   EQU  >8301
PAD5F  EQU  >835F
PADC2  EQU  >83C2
*
VAR0   EQU  >8300
MNUM   EQU  >8302
MNUM1  EQU  >8303
PABPTR EQU  >8304
CCPPTR EQU  >8306
CCPADR EQU  >8308
RAMPTR EQU  >830A
CALIST EQU  RAMPTR
BYTE   EQU  >830C
PROAZ  EQU  >8310
VAR5   EQU  PROAZ
PZ     EQU  >8312
LINUM  EQU  PZ
OEZ    EQU  >8314
QZ     EQU  >8316
XFLAG  EQU  QZ
VAR9   EQU  QZ
DSRFLG EQU  >8317
FORNET EQU  DSRFLG
STRSP  EQU  >8318
CZ     EQU  >831A
STREND EQU  CZ
WSM    EQU  CZ
SREF   EQU  >831C * Temporary string pointer
WSM2   EQU  SREF  * Temporary string pointer
WSM4   EQU  >831E * Start of current statement
SMTSRT EQU  WSM4  * Start of current statement
WSM6   EQU  >8320 * Screen address
VARW   EQU  WSM6  * Screen address
VARW1  EQU  >8321
ERRCOD EQU  >8322 * Return error code from ALC
WSM8   EQU  ERRCOD * Return error code from ALC
ERRCO1 EQU  >8323
STVSPT EQU  >8324 * Value-stack base
RTNADD EQU  >8326
NUDTAB EQU  >8328
VARA   EQU  >832A * Ending display location
PGMPTR EQU  >832C * Program text pointer
PGMPT1 EQU  >832D
EXTRAM EQU  >832E * Line number table pointer
EXTRM1 EQU  >832F
STLN   EQU  >8330 * Start of line number table
ENLN   EQU  >8332 * End of line number table
DATA   EQU  >8334 * Data pointer for READ
LNBUF  EQU  >8336 * Line table pointer for READ
INTRIN EQU  >8338 * Add of intrinsic poly constant
SUBTAB EQU  >833A * Subprogram symbol table
SYMTAB EQU  >833E * Symbol table pointer
SYMTA1 EQU  >833F
FREPTR EQU  >8340 * Free space pointer
CHAT   EQU  >8342 * Current charater/token
BASE   EQU  >8343 * OPTION BASE value
PRGFLG EQU  >8344 * Program/imperative flag
FLAG   EQU  >8345 * General 8-bit flag
BUFLEV EQU  >8346 * Crunch-buffer destruction level
LSUBP  EQU  >8348 * Last subprogram block on stack
FAC    EQU  >834A * Floating-point ACcurmulator
FAC1   EQU  >834B
FAC2   EQU  >834C
FAC4   EQU  >834E
FAC5   EQU  >834F
FAC6   EQU  >8350
FAC7   EQU  >8351
FAC8   EQU  >8352
FAC9   EQU  >8353
FAC10  EQU  >8354
FLTNDX EQU  FAC10
FDVSR  EQU  FAC10
FAC11  EQU  >8355
SCLEN  EQU  FAC11
FDVSR1 EQU  FAC11
FAC12  EQU  >8356
FDVSR2 EQU  FAC12
FAC13  EQU  >8357
FAC14  EQU  >8358
FAC15  EQU  >8359
FAC16  EQU  >835A
FDVSR8 EQU  >835C * Floating-point ARGument
ARG    EQU  FDVSR8 * Floating-point ARGument
ARG1   EQU  >835D
ARG2   EQU  >835E
ARG3   EQU  >835F
ARG4   EQU  >8360
ARG8   EQU  >8364
ARG9   EQU  >8365
ARG10  EQU  >8366
FAC33  EQU  >836B
TEMP2  EQU  >836C
FLTERR EQU  TEMP2
TYPE   EQU  >836D
VSPTR  EQU  >836E * Value stack pointer
VSPTR1 EQU  >836F
STKDAT EQU  >8372
STKADD EQU  >8373
STACK  EQU  >8373
PLAYER EQU  >8374
KEYBRD EQU  >8375
SIGN   EQU  KEYBRD
JOYY   EQU  >8376 * Exponent in floating-point
EXP    EQU  JOYY
JOYX   EQU  >8377
RANDOM EQU  >8378
TIME   EQU  >8379
MOTION EQU  >837A
VDPSTS EQU  >837B
STATUS EQU  >837C
CHRBUF EQU  >837D
YPT    EQU  >837E
XPT    EQU  >837F
RAMFLG EQU  >8389 * ERAM flag
STKEND EQU  >83BA
STND12 EQU  STKEND-12
CRULST EQU  >83C0
SAVEG  EQU  >83CB
SADDR  EQU  >83D2
RAND16 EQU  >83D4
*
WS     EQU  >83E0
R0LB   EQU  >83E1
R1LB   EQU  >83E3
R2LB   EQU  >83E5
R3LB   EQU  >83E7
R4LB   EQU  >83E9
R5LB   EQU  >83EB
R6LB   EQU  >83ED
R7LB   EQU  >83EF
R8LB   EQU  >83F1
R9LB   EQU  >83F3
R10LB  EQU  >83F5
R11LB  EQU  >83F7
R12LB  EQU  >83F9
R13LB  EQU  >83FB
R14LB  EQU  >83FD
R15LB  EQU  >83FF
*
GDST   EQU  >8302
AAA11  EQU  >8303
GDST1  EQU  >8303
VARY   EQU  >8304
VARY2  EQU  >8306
BCNT2  EQU  >8308
CSRC   EQU  >830C
ADDR1  EQU  >834C
ADDR11 EQU  >834D
BCNT1  EQU  >834E
ADDR2  EQU  >8350
ADDR21 EQU  >8351
GSRC   EQU  >8354
DDD11  EQU  >8355
GSRC1  EQU  >8355
BCNT3  EQU  >8356
DEST   EQU  >8358
DEST1  EQU  >8359
RAMTOP EQU  >8384
* VDP variables
SYMBOL EQU  >0376 * Saved symbol table pointer
ERRLN  EQU  >038A * On-error line pointer
TABSAV EQU  >0392 * Saved main symbol table ponter
VROAZ  EQU  >03C0 * Temporary VDP Roll Out Area
FPSIGN EQU  >03DC
CRNBUF EQU  >0820 * CRuNch BUFfer address
CRNEND EQU  >08BE * CRuNch buffer END
********************************************************************************
       AORG >6000
       TITL 'XML359'
 
* PAGE SELECTOR FOR PAGE 1
PAGE1  EQU  $                 >6000
C2     DATA 2                 0
* PAGE SELECTOR FOR PAGE 2
PAGE2  EQU  $                 >6002
C7     BYTE >00
CBH7   BYTE >07               2
CBHA   BYTE >0A
CBH94  BYTE >94               4
C40    DATA 40                6
C100   DATA 100               8
C1000  DATA >1000             A
       DATA 0                 C
FLTONE DATA >4001             E
*************************************************************
* XML table number 7 for Extended Basic - must have         *
*     it's origin at >6010                                  *
*************************************************************
*           0      1      2      3      4      5     6
       DATA COMPCG,GETSTG,MEMCHG,CNSSEL,PARSEG,CONTG,EXECG
*           7      8    9     A    B    C      D
       DATA VPUSHG,VPOP,PGMCH,SYMB,SMBB,ASSGNV,FBSYMB
*             E     F
       DATA SPEED,CRNSEL
*************************************************************
* XML table number 8 for Extended Basic - must have         *
*     it's origin at >6030                                  *
*************************************************************
*           0   1      2    3      4  5     6      7
       DATA CIF,CONTIN,RTNG,SCROLL,IO,GREAD,GWRITE,DELREP
*           8    9    A      B      C      D      E
       DATA MVDN,MVUP,VGWITE,GVWITE,GREAD1,GWITE1,GDTECT
*           F
       DATA PSCAN
 
* Determine if and how much ERAM is present
GDTECT MOVB R11,@PAGE1        First enable page 1 ROM
*-----------------------------------------------------------*
* Replace following line      6/16/81                       *
* (Extended Basic must be made to leave enough space at     *
* top of RAM expansion for the "hooks" left by the 99/4A    *
* for TIBUG.)                                               *
*      SETO R0                Start at >FFFF                *
* with                                                      *
*      LI   R0,>FFE7          Start at >FFE7                *
*************************************************************
* RXB 2020 change for PRAM command                          *
       MOV  @RAMTOP,R0        PRAM sets RAMTOP value
*-----------------------------------------------------------*
       MOVB R11,*R0           Write a byte of data
       CB   R11,*R0           Read and compare the data
       JEQ  DTECT2            If matches-found ERAM top
*-----------------------------------------------------------*
* Change the following line   6/16/81                       *
*      AI   R0,->2000         Else drop down 8K             *
       LI   R0,>DFFF          Else drop down 8K
*-----------------------------------------------------------*
       MOVB R11,*R0           Write a byte of data
       CB   R11,*R0           Read and compare the data
       JEQ  DTECT2            If matches-found ERAM top
       CLR  R0                No match so no ERAM
DTECT2 MOV  R0,@RAMTOP        Set the ERAM top
       RT                     And return to GPL
CNSSEL LI   R2,CNS
       JMP  PAGSEL
CRNSEL LI   R2,CRUNCH
* Select page 2 for CRUNCH and CNS
PAGSEL INCT @STKADD           Get space on subroutine stack
       MOVB @STKADD,R7        Get stack pointer
       SRL  R7,8              Shift to use as offset
       MOVB R11,@PAD0(R7)     Save return addr to GPL interpeter
       MOVB @R11LB,@PAD1(R7)
       MOVB R11,@PAGE2        Select page 2
       BL   *R2               Do the conversion
       MOVB R11,@PAGE1        Reselect page 1
       MOVB @STKADD,R7        Get subroutine stack pointer
       DECT @STKADD           Decrement pointer
       SRL  R7,8              Shift to use as offset
       MOVB @PAD0(R7),R11     Restore return address
       MOVB @PAD1(R7),@R11LB
       RT                     Return to GPL interpeter
GETCH  MOVB @R6LB,*R15
       NOP
       MOVB R6,*R15
       INC  R6
       MOVB @XVDPRD,R8
GETCH1 SRL  R8,8
       RT
GETCHG MOVB R6,@GRMWAX(R13)
       MOVB @R6LB,@GRMWAX(R13)
       INC  R6
       MOVB *R13,R8
       JMP  GETCH1
GETCGR MOVB *R6+,R8
       JMP  GETCH1
*
CBHFF  EQU  $+2
POPSTK LI   R5,-8
       MOVB @VSPTR1,*R15
       LI   R6,ARG
       MOVB @VSPTR,*R15
       A    R5,@VSPTR
STKMOV MOVB @XVDPRD,*R6+
       INC  R5
       JNE  STKMOV
       RT
*
PUTSTK INCT @STKADD
       MOVB @STKADD,R4
       SRL  R4,8
       MOVB @GRMRAX(13),@PAD0(R4)
       MOVB @GRMRAX(13),@PAD1(R4)
       DEC  @PAD0(R4)
       RT
*
GETSTK MOVB @STKADD,R4
       SRL  R4,8
       DECT @STKADD
       MOVB @PAD0(R4),@GRMWAX(R13)
       MOVB @PAD1(R4),@GRMWAX(R13)
       RT
********************************************************************************
       AORG >6126
       TITL 'REFS359'
 
ROUNUP EQU  >0F64   Uses XML >01 Rounding of floating point numbers
SCOMPB EQU  >0D42   Set SCOMP with direct return without GPL status
CFI    EQU  >12B8   CFI (XML >12)
SMULT  EQU  >0E8C   SMUL (XML >0D)
FDIV   EQU  >0FF4   FDIV (XML >09)
OVEXP  EQU  >0FC2   Overflow (XML >04)
FMULT  EQU  >0E88   FMUL (XML >08)
SSUB   EQU  >0D74   SSUB (XML >0C)
FADD   EQU  >0D80   FADD (XML >06)
SDIV   EQU  >0FF8   SDIV (XML >0E)
FSUB   EQU  >0D7C   FSUB (XML (>07)
SADD   EQU  >0D84   SADD (XML >0B)
ROUNU  EQU  >0FB2   Rounding with digit number in >8354 (XML >02)
RESET  EQU  >006A   Clear condition bit in GPL status (GPL interpreter)
NEXT   EQU  >0070   GPL interpreter
CSN01  EQU  >11B2   CSN (XML >10) (Without R3 loaded with >1FC8)
FCOMP  EQU  >0D3A   FCOMP (XML >0A)
FCOMPB MOV  R11,R3
       B    @FCOMP+22
GETV   EQU  >187C   Read 1 byte from VDP, Entry over data address pointer
GETV1  EQU  >1880   Same >187C but does not fetch address, is preloaded first
SAVREG EQU  >1E8C   Set substack pointer and Basic byte
SAVRE2 EQU  >1E90   Same >1E8C but does not set R8 into >8342
SETREG EQU  >1E7A   Substack pointer in R9 and actual Basic byte in R8
STVDP3 EQU  >18AA   Write R6 in VDP (R1=Address+3), 
*                   used for variable table and string pointer
STVDP  EQU  >18AE   Write R6 in VDP (R1=Address+3), 
*                   used for variable table and string pointer. (R3 Preloaded)
FBS    EQU  >15E0   Pointer fetch var list
FBS001 EQU  >15E6   Fetch length byte
********************************************************************************
 
       AORG >612C
       TITL 'CPT'
 
*
* The CHARACTER PROPERTY TABLE
* There is a one-byte entry for every character code
* in the range LLC(lowest legal character) to
* HLC(highest legal character), inclusive.
LLC    EQU  >20
CPNIL  EQU  >00               " $ % ' ?
CPDIG  EQU  >02               digit (0-9)
CPNUM  EQU  >04               digit, period, E
CPOP   EQU  >08               1 char operators(!#*+-/<=>^ )
CPMO   EQU  >10               multiple operator ( : )
CPALPH EQU  >20               A-Z, @, _
CPBRK  EQU  >40               ( ) , ;
CPSEP  EQU  >80               space
CPALNM EQU  CPALPH+CPDIG      alpha-digit
*-----------------------------------------------------------*
* Following lines are for adding lowercase character set in *
* 99/4A,                      5/12/81                       *
CPLOW  EQU  >01               a-z                           *
CPULNM EQU  CPALNM+CPLOW      Alpha(both upper and lower)+  *
*                             digit-legal variable characters
CPUL   EQU  CPALPH+CPLOW      Alpha(both upper and lower)   *
*-----------------------------------------------------------*
CPTBL  EQU  $-LLC
       BYTE CPSEP               SPACE
       BYTE CPOP              ! EXCLAMATION POINT
       BYTE CPNIL             " QUOTATION MARKS
       BYTE CPOP              # NUMBER SIGN
       BYTE CPNIL             $ DOLLAR SIGN
       BYTE CPNIL             % PERCENT
       BYTE CPOP              & AMPERSAND
       BYTE CPNIL             ' APOSTROPHE
       BYTE CPBRK             ( LEFT PARENTHESIS
       BYTE CPBRK             ) RIGHT PARENTHESIS
       BYTE CPOP              * ASTERISK
       BYTE CPOP+CPNUM        + PLUS
       BYTE CPBRK             , COMMA
       BYTE CPOP+CPNUM        - MINUS
       BYTE CPNUM             . PERIOD
       BYTE CPOP              / SLANT
       BYTE CPNUM+CPDIG       0 ZERRO
       BYTE CPNUM+CPDIG       1 ONE
       BYTE CPNUM+CPDIG       2 TWO
       BYTE CPNUM+CPDIG       3 THREE
       BYTE CPNUM+CPDIG       4 FOUR
       BYTE CPNUM+CPDIG       5 FIVE
       BYTE CPNUM+CPDIG       6 SIX
       BYTE CPNUM+CPDIG       7 SEVEN
       BYTE CPNUM+CPDIG       8 EIGHT
       BYTE CPNUM+CPDIG       9 NINE
LBCPMO BYTE CPMO              : COLON
       BYTE CPBRK             : SEMICOLON
       BYTE CPOP              < LESS THAN
       BYTE CPOP              = EQUALS
       BYTE CPOP              > GREATER THAN
       BYTE CPNIL             ? QUESTION MARK
       BYTE CPALPH            @ COMMERCIAL AT
       BYTE CPALPH            A UPPERCASE A
       BYTE CPALPH            B UPPERCASE B
       BYTE CPALPH            C UPPERCASE C
       BYTE CPALPH            D UPPERCASE D
       BYTE CPALPH+CPNUM      E UPPERCASE E
       BYTE CPALPH            F UPPERCASE F
       BYTE CPALPH            G UPPERCASE G
       BYTE CPALPH            H UPPERCASE H
       BYTE CPALPH            I UPPERCASE I
       BYTE CPALPH            J UPPERCASE J
       BYTE CPALPH            K UPPERCASE K
       BYTE CPALPH            L UPPERCASE L
       BYTE CPALPH            M UPPERCASE M
       BYTE CPALPH            N UPPERCASE N
       BYTE CPALPH            O UPPERCASE O
       BYTE CPALPH            P UPPERCASE P
       BYTE CPALPH            Q UPPERCASE Q
       BYTE CPALPH            R UPPERCASE R
       BYTE CPALPH            S UPPERCASE S
       BYTE CPALPH            T UPPERCASE T
       BYTE CPALPH            U UPPERCASE U
       BYTE CPALPH            V UPPERCASE V
       BYTE CPALPH            W UPPERCASE W
       BYTE CPALPH            X UPPERCASE X
       BYTE CPALPH            Y UPPERCASE Y
       BYTE CPALPH            Z UPPERCASE Z
       BYTE CPALPH            [ LEFT SQUARE BRACKET
       BYTE CPALPH            \ REVERSE SLANT
       BYTE CPALPH            ] RIGHT SQUARE BRACKET
       BYTE CPOP              ^ CIRCUMFLEX
       BYTE CPALPH            _ UNDERLINE
*-----------------------------------------------------------*
* Following "`" and lowercase characters are for            *
* adding lowercase character set in 99/4A, 5/12/81          *
*-----------------------------------------------------------*
       BYTE CPNIL             ` GRAVE ACCENT
       BYTE CPALPH+CPLOW      a LOWERCASE a
       BYTE CPALPH+CPLOW      b LOWERCASE b
       BYTE CPALPH+CPLOW      c LOWERCASE c
       BYTE CPALPH+CPLOW      d LOWERCASE d
       BYTE CPALPH+CPLOW      e LOWERCASE e
       BYTE CPALPH+CPLOW      f LOWERCASE f
       BYTE CPALPH+CPLOW      g LOWERCASE g
       BYTE CPALPH+CPLOW      h LOWERCASE h
       BYTE CPALPH+CPLOW      i LOWERCASE i
       BYTE CPALPH+CPLOW      j LOWERCASE j
       BYTE CPALPH+CPLOW      k LOWERCASE k
       BYTE CPALPH+CPLOW      l LOWERCASE l
       BYTE CPALPH+CPLOW      m LOWERCASE m
       BYTE CPALPH+CPLOW      n LOWERCASE n
       BYTE CPALPH+CPLOW      o LOWERCASE o
       BYTE CPALPH+CPLOW      p LOWERCASE p
       BYTE CPALPH+CPLOW      q LOWERCASE q
       BYTE CPALPH+CPLOW      r LOWERCASE r
       BYTE CPALPH+CPLOW      s LOWERCASE s
       BYTE CPALPH+CPLOW      t LOWERCASE t
       BYTE CPALPH+CPLOW      u LOWERCASE u
       BYTE CPALPH+CPLOW      v LOWERCASE v
       BYTE CPALPH+CPLOW      w LOWERCASE w
       BYTE CPALPH+CPLOW      x LOWERCASE x
       BYTE CPALPH+CPLOW      y LOWERCASE y
       BYTE CPALPH+CPLOW      z LOWERCASE z
 
       EVEN
********************************************************************************
       AORG >6188
       TITL 'BASSUP'
 
* General Basic support routines (not includeing PARSE)
 
*
ERRBS  EQU  >0503             BAD SUBSCRIPT ERROR CODE
ERRTM  EQU  >0603             ERROR STRING/NUMBER MISMATCH
*
STCODE DATA >6500
C6     DATA >0006
*
* Entry to find Basic symbol table entry for GPL
*
FBSYMB BL   @FBS              Search the symbol table
       DATA RESET             If not found - condition reset
SET    SOCB @BIT2,@STATUS     Set GPL condition
       B    @NEXT             If found - condition set
* GPL entry for COMPCT to take advantage of common code
COMPCG  LI   R6,COMPCT        Address of COMPCT
       JMP  SMBB10            Jump to set up
* GPL entry for GETSTR to take advantage of common code
GETSTG LI   R6,GETSTR         Address of MEMCHK
       JMP  SMBB10            Jump to set up
* GPL entry for SMB to take advantage of common code
SMBB   LI   R6,SMB            Address of SMB routine
       JMP  SMBB10            Jump to set up
* GPL entry for ASSGNV to take advantage of common code
ASSGNV LI   R6,ASSG           Address of ASSGNV routine
       JMP  SMBB10            Jump to set up
* GPL entry for SMB to take advantage of common code
SYMB   LI   R6,SYM            Address of SYM routine
       JMP  SMBB10            Jump to set up
* GPL entry for SMB to take advantage of common code
VPUSHG LI   R6,VPUSH          Address of VPUSH routine
SMBB10 MOV  R11,R7            Save return address
       BL   @PUTSTK           Save current GROM address
       BL   @SETREG           Set up Basic registers
       INCT R9                Get space on subroutine stack
       MOV  R7,*R9            Save the return address
       BL   *R6               Branch and link to the routine
       MOV  *R9,R7            Get return address
       DECT R9                Restore subroutine stack
       BL   @SAVREG           Save registers for GPL
       BL   @GETSTK           Restore GROM address
       B    *R7               Return to GPL
*************************************************************
* Subroutine to find the pointer to variable space of each  *
* element of symbol table entry. Decides whether symbol     *
* table entry pointed to by FAC, FAC+1 is a simple variable *
* and returns proper 8-byte block in FAC through FAC7       *
*************************************************************
SMB    INCT R9                Get space on subroutine stack
       MOV  R11,*R9           Save return address
       MOV  @FAC,@FAC4        Copy pointer to table entry
       A    @C6,@FAC4         Add 6 so point a value space
       BL   @GETV             Get 1st byte of table entry
       DATA FAC               Pointer is in FAC
*
       MOV  R1,R4             Copy for later use.
       MOV  R1,R2             Copy for later use.
       SLA  R1,2              Check for UDF entry
       JOC  BERMUV            If UDF - then error
       MOV  R4,R4             Check for string.
       JLT  SMB02             Skip if it is string.
       CLR  @FAC2             Clear for numeric case.
*
* In case of subprogram call check if parameter is shared by
* it's  calling program.
*
SMB02  SLA  R1,1              Check for the shared bit.
       JNC  SMB04             If it is not shared skip.
       BL   @GET              Get the value space pointer
       DATA FAC4                in the symbol table.
       MOV  R1,@FAC4          Store the value space address.
*
* Branches to take care of string and array cases.
* Only the numeric variable case stays on.
*
SMB04  MOVB R4,R4             R4 has header byte information.
       JLT  SMBO50            Take care of string.
SMB05  SLA  R4,5              Get only the dimension number.
       SRL  R4,13
       JNE  SMBO20             go to array case.
*
* Numeric ERAM cases are special.
* If it is shared get the actual v.s. address from ERAM.
* Otherwise get it from VDP RAM.
*
       MOVB @RAMTOP,R4        Check for ERAM.
       JEQ  SMBO10            Yes ERAM case.
       SLA  R2,3              R2 has a header byte.
       JNC  SMB06             Shared bit is not ON.
       BL   @GETG             Get v.s. pointer from ERAM
       DATA FAC4
       JMP  SMB08
SMB06  BL   @GET              Not shared.
       DATA FAC4              Get v.s. address from VDP RAM.
*
SMB08  MOV  R1,@FAC4          Store it in FAC4 area.
*
* Return from the SMB routine.
*
SMBO10 MOV  *R9,R11           Restore return address
       DECT R9                Restore stack
       RT                     And return
BERMUV B    @ERRMUV           * INCORRECT NAME USAGE
*
* Start looking for the real address of the symbol.
*
SMBO50 CI   R8,LPARZ*256      String - now string array?
       JEQ  SMB05             Yes, process as an array
SMB51  MOV  @STCODE,@FAC2     String ID code in FAC2
       MOV  @FAC4,@FAC        Get string pointer address
       BL   @GET              Get exact pointer to string
       DATA FAC
*
       MOV  R1,@FAC4          Save pointer to string
       MOV  R1,R3             Was it a null?
       JEQ  SMB57             Length is 0 - so is null
       DEC  R3                Otherwise point at length byte
       BL   @GETV1            Get the string length
       SRL  R1,8              Shift for use as double
SMB57  MOV  R1,@FAC6          Put into FAC entry
       JMP  SMBO10            And return
*
* Array cases are taken care of here.
*
SMBO20  MOV R4,@FAC2          Now have a dimension counter
*                              that is initilized to maximum.
*  *FAC+4,FAC+5 already points to 1st dimension maximum in
*    in symbol table.
       CLR  R2                Clear index accumulator
SMBO25 MOV  R2,@FAC6          Save accumulator in FAC
       BL   @PGMCHR           Get next character
       BL   @PSHPRS           PUSH and PARSE subscript
       BYTE LPARZ,0           Up to a left parenthesis or less
*
       CB   @FAC2,@STCODE     Dimension can't be a string
       JHE  ERRT              It is - so error
* Now do float to interger conversion of dimension
       CLR  @FAC10            Assume no error
       BL   @CFI              Gets 2 byte integer in FAC,FAC1
       MOVB @FAC10,R4         Error on conversion?
       JNE  ERR3              Yes, error BAD SUBSCRIPT
       MOV  @FAC,R5           Save index just read
       BL   @VPOP             Restore FAC block
       BL   @GET              Get next dimension maximum
       DATA FAC4              FAC4 points into symbol table
*
       C    R5,R1             Subscript less-then maximum?
       JH   ERR3              No, index out of bounds
BIT2   EQU  $+1               Constant >20 (Opcode is >D120)
       MOVB @BASE,R4          Fetch option base to check low
       JEQ  SMBO40            If BASE=0, INDEX=0 is ok
       DEC  R5                Adjust BASE 1 index
       JLT  ERR3              If subscript was =0 then error
       JMP  SMBO41            Accumulate the subscripts
SMBO40 INC  R1                Adjust size if BASE=0
SMBO41 MPY  @FAC6,R1          R1,R2 has ACCUM*MAX dimension
       A    R5,R2             Add latest to accumulator
       INCT @FAC4             Increment dimension max pointer
       DEC  @FAC2             Decrement remaining-dim count
       JEQ  SMBO70            All dimensions handled ->done
       CI   R8,COMMAZ*256     Otherwise, must be at a comma
       JEQ  SMBO25            We are, so loop for more
ERR1   B    @ERRSYN           Not a comma, so SYNTAX ERROR
*
* At this point the required number of dimensions have been
*  scanned.
* R2 Contains the index
* R4 Points to the first array element or points to the
*  address in ERAM where the first array element is.
SMBO70 CI   R8,RPARZ*256      Make sure at a right parenthesis
       JNE  ERR1              Not, so error
       BL   @PGMCHR           Get nxt token
       BL   @GETV             Now check string or numeric
       DATA FAC                array by checking s.t.
*
       JLT  SMB71             If MSB set is a string array
       SLA  R2,3              Numeric, multiply by 8
       MOVB @RAMTOP,R3        Does ERAM exist?
       JEQ  SMBO71            No
       BL   @GET              Yes, get the content of value
       DATA FAC4               pointer
*
       MOV  R1,@FAC4          Put it in FAC4
SMBO71 A    R2,@FAC4          Add into values pointer
       JMP  SMBO10            And return in the normal way
SMB71  SLA  R2,1              String, multiply by 2
       A    R2,@FAC4          Add into values pointer
       JMP  SMB51             And build the string FAC entry
ERR3   LI   R0,ERRBS          Bad subscript return vector
ERRX   B    @ERR              Exit to GPL
ERRT   LI   R0,ERRTM          String/number mismatch vector
       JMP  ERRX              Use the long branch
*************************************************************
* Subroutine to put symbol name into FAC and to call FBS to *
* find the symbol table for the symbol                      *
*************************************************************
SYM    CLR  @FAC15            Clear the caharacter counter
       LI   R2,FAC            Copying string into FAC
       MOV  R11,R1            Save return address
*-----------------------------------------------------------*
* Fix "A long constant in a variable field in INPUT,        *
*      ACCEPT, LINPUT, NEXT and READ etc. may crash the     *
*      sytem" bug,            5/22/81
* Insert the following 2 lines
       MOVB R8,R8
       JLT  ERR1              If token
SYM1   MOVB R8,*R2+           Save the character
       INC  @FAC15            Count it
       BL   @PGMCHR           Get next character
       JGT  SYM1              Still characters in the name
       BL   @FBS              Got name, now find s.t. entry
       DATA ERR1              Return vector if not found
*
       B    *R1               Return to caller if found
*************************************************************
* ASSGNV, callable from GPL or 9900 code, to assign a value *
* to a symbol (strings and numerics) . If numeric, the      *
* 8 byte descriptor is in the FAC. The descriptor block     *
* (8 bytes) for the destination variable is on the stack.   *
* There are two types of descriptor entries which are       *
* created by SMB in preparation for ASSGNV, one for         *
* numerics and one for strings.                             *
*                     NUMERIC                               *
* +-------------------------------------------------------+ *
* |S.T. ptr | 00 |       |Value ptr |                     | *
* +-------------------------------------------------------+ *
*                     STRING
* +-------------------------------------------------------+ *
* |Value ptr| 65 |       |String ptr|String length        | *
* +-------------------------------------------------------+ *
*                                                           *
* CRITICAL NOTE: Becuase of the BL @POPSTK below, if a      *
* string entry is popped and a garbage collection has taken *
* place while the entry was pushed on the stack, and the    *
* entry was a permanent string the pointer in FAC4 and FAC5 *
* will be messed up. A BL @VPOP would have taken care of    *
* the problem but would have taken a lot of extra code.     *
* Therefore, at ASSG50-ASSG54 it is assumed that the        *
* previous value assigned to the destination variable has   *
* been moved and the pointer must be reset by going back to *
* the symbol table and getting the correct value pointer.   *
*************************************************************
ASSG   MOV  R11,R10           Save the retun address
       BL   @ARGTST           Check arg and variable type
       STST R12               Save status of type
       BL   @POPSTK           Pop destination descriptor
*                              into ARG
       SLA  R12,3             Variable type numeric?
       JNC  ASSG70            Yes, handle it as such
* Assign a string to a string variable
       MOV  @ARG4,R1          Get destination pointer
*                             Dest have non-null  value?
       JEQ  ASSG54            No, null->never assigned
* Previously assigned - Must first free the old value
       BL   @GET              Correct for POPSTK above
       DATA ARG               Pointer is in ARG
*
       MOV  R1,@ARG4          Correct ARG+4,5 too
*-----------------------------------------------------------*
* Fix "Assigning a string to itself when memory is full can *
*      destroy the string" bug, 5/22/81                     *
* Add the following 2 lines and the label ASSG80            *
       C    R1,@FAC4          Do not do anything in assign- *
*                              ing a string to itself case  *
       JEQ  ASSG80            Detect A$=A$ case, exit       *
*-----------------------------------------------------------*
       CLR  R6                Clear for zeroing backpointer
       BL   @STVDP3           Free the string
ASSG54 MOV  @FAC6,R4          Is source string a null?
       JEQ  ASSG57            Yes, handle specially
       MOV  @FAC,R3           Get address of source pointer
       CI   R3,>001C          Got a temporay string?
       JNE  ASSG56            No, more complicated
       MOV  @FAC4,R4          Pick up direct ptr to string
* Common string code to set forward and back pointers
ASSG55 MOV  @ARG,R6           Ptr to symbol table pointer
       MOV  R4,R1             Pointer to source string
       BL   @STVDP3           Set the backpointer
ASSG57 MOV  @ARG,R1           Address of symbol table ptr
       MOV  R4,R6             Pointer to string
       BL   @STVDP            Set the forward pointer
ASSG80 B    *R10              Done, return
* Symbol-to-symbol assigments of strings
* Must create copy of string
ASSG56 MOV  @FAC6,@BYTE       Fetch length for GETSTR
* NOTE: FAC through FAC+7 cannot be destroyed
*       address^of string length^of string
       BL   @VPUSH            So save it on the stack
       MOV  R10,@FAC          Save return link in FAC since
*                              GETSTR does not destroy FAC
       BL   @GETSTR           Call GPL to do the GETSTR
       MOV  @FAC,R10          Restore return link
       BL   @VPOP             Pop the source info back
* Set up to copy the source string into destination
       MOV  @FAC4,R3          R3 is now copy-from
       MOV  @SREF,R5          R5 is now copy-to
       MOV  R5,R4             Save for pointer setting
* Registers to be used in the copy
* R1 - Used for a buffer
* R3 - Copy-from address
* R2 - # of bytes to be moved
* R5 - copy-to address
       MOV  @FAC6,R2          Fetch the length of the string
       ORI  R5,WRVDP          Enable the VDP write
ASSG59 BL   @GETV1            Get the character
       MOVB @R5LB,*R15        Load out destination address
       INC  R3                Increment the copy-from
       MOVB R5,*R15           1st byte of address to
       INC  R5                Increment for next character
       MOVB R1,@XVDPWD        Put the character out
       DEC  R2                Decrement count, finished?
       JGT  ASSG59            No, loop for more
       JMP  ASSG55            Yes, now set pointers
* Code to copy a numeric value into the symbol table
ASSG70 LI   R2,8              Need to assign 8 bytes
       MOV  @ARG4,R5          Destination pointer(R5)
*                              from buffer(R4), (R2)bytes
       MOV  @RAMTOP,R3        Does ERAM exist?
       JNE  ASSG77            Yes, write to ERAM
*                             No, write to VDP
       MOVB @R5LB,*R15        Load out 2nd byte of address
       ORI  R5,WRVDP          Enable the write to the VDP
       MOVB R5,*R15           Load out 1st byte of address
       LI   R4,FAC            Source is FAC
ASSG75 MOVB *R4+,@XVDPWD      Move a byte
       DEC  R2                Decrement the counter, done?
       JGT  ASSG75            No, loop for more
       B    *R10              Yes, return to the caller
ASSG77 LI   R4,FAC            Source is in FAC
ASSG79 MOVB *R4+,*R5+         Move a byte
       DEC  R2                Decrement the counter, done?
       JGT  ASSG79            No, loop for more
       B    *R10              Yes, return to caller
* Check for required token
SYNCHK MOVB *R13,R0           Read required token
*
       CB   R0,@CHAT          Have the required token?
       JEQ  PGMCH             Yes, read next character
       BL   @SETREG           Error return requires R8/R9 set
       B    @ERRSYN           * SYNTAX ERROR
*      PGMCH - GPL entry point for PGMCHR to set up registers
PGMCH  MOV  R11,R12           Save return address
       BL   @PGMCHR           Get the next character
       MOVB R8,@CHAT          Put it in for GPL
       B    *R12              Return to GPL
       RT                     And return to the caller
PUTV   MOV  *R11+,R4
       MOV  *R4,R4
PUTV1  MOVB @R4LB,*R15
       ORI  R4,WRVDP
       MOVB R4,*R15
       NOP
       MOVB R1,@XVDPWD
       RT
* MOVFAC - copies 8 bytes from VDP(@FAC4) or ERAM(@FAC4)
*          to FAC
MOVFAC MOV @FAC4,R1           Get pointer to source
       LI  R2,8               8 byte values
       LI  R3,FAC             Destination is FAC
       MOV @RAMTOP,R0         Does ERAM exist?
       JNE MOVFA2             Yes, from ERAM
*                             No, from VDP RAM
       SWPB R1
       MOVB R1,*R15           Load 2nd byte of address
       SWPB R1
       MOVB R1,*R15           Load 1st byte of address
       LI   R5,XVDPRD
MOVF1  MOVB *R5,*R3+          Move a byte
       DEC  R2                Decrement counter, done?
       JGT  MOVF1             No, loop for more
       RT                     Yes, return to caller
MOVFA2 MOVB *R1+,*R3+
       DEC  R2
       JNE  MOVFA2
       RT
       RT                     And return to caller
********************************************************************************
       AORG >6464
       TITL 'PARSES'
 
*      BASIC PARSE CODE
* REGISTER USAGE
*    RESERVED FOR GPL INTERPRETER  R13, R14, R15
*          R13 contains the read address for GROM
*          R14 is used in BASSUP/10 for the VDPRAM pointer
*    RESERVED IN BASIC SUPPORT
*          R8 MSB current character (like CHAT in GPL)
*          R8 LSB zero
*          R10 read data port address for program data
*   ALL EXITS TO GPL MUST GO THROUGH "NUDG05"
*
 
*                         ~~~TOKENS~~~
ELSEZ  EQU  >81               ELSE
SSEPZ  EQU  >82               STATEMENT SEPERATOR
TREMZ  EQU  >83               TAIL REMARK
IFZ    EQU  >84               IF
GOZ    EQU  >85               GO
GOTOZ  EQU  >86               GOTO
GOSUBZ EQU  >87               GOSUB
BREAKZ EQU  >8E               BREAK
NEXTZ  EQU  >96               NEXT
SUBZ   EQU  >A1               SUB
ERRORZ EQU  >A5               ERROR
WARNZ  EQU  >A6               WARNING
THENZ  EQU  >B0               THEN
TOZ    EQU  >B1               TO
COMMAZ EQU  >B3               COMMA
RPARZ  EQU  >B6               RIGHT PARENTHESIS )
LPARZ  EQU  >B7               LEFT PARENTHESIS (
ORZ    EQU  >BA               OR
ANDZ   EQU  >BB               AND
XORZ   EQU  >BC               XOR
NOTZ   EQU  >BD               NOT
EQZ    EQU  >BE               EQUAL (=)
GTZ    EQU  >C0               GREATER THEN (>)
PLUSZ  EQU  >C1               PLUS (+)
MINUSZ EQU  >C2               MINUS (-)
DIVIZ  EQU  >C4               DIVIDE (/)
EXPONZ EQU  >C5               EXPONENT
STRINZ EQU  >C7               STRING
LNZ    EQU  >C9               LINE NUMBER
ABSZ   EQU  >CB               ABSOLUTE
SGNZ   EQU  >D1               SIGN
*
C24    DATA 24                CONSTANT 24
EXRTNA DATA EXRTN             RETURN FOR EXEC
*
ERRSO  LI   R0,>0703          Issue STACK OVERFLOW message
       B    @ERR
*
* GRAPHICS LANGUAGE ENTRY TO PARSE
*
PARSEG BL   @SETREG           Set up registers for Basic
       MOVB @GRMRAX(R13),R11  Get GROM address
       MOVB @GRMRAX(R13),@R11LB
       DEC  R11
*
* 9900 ENTRY TO PARSE
*
PARSE  INCT R9                Get room for return address
       CI   R9,STKEND         Stack full?
       JH   ERRSO             Yes, too many levels deep
       MOV  R11,*R9           Save the return address
P05    MOVB R8,R7             Test for token beginning
       JLT  P10               If token, then look it up
       B    @PSYM             If not token is a symbol
P10    BL   @PGMCHR           Get next character
       SRL  R7,7              Change last character to offset
       AI   R7,->B7*2         Check for legal NUD
       CI   R7,NTABLN         Within the legal NUD address?
       JH   CONT15            No, check for legal LED
       MOV  @NTAB(R7),R7      Get NUD address
       JGT  B9900             If 9900 code
P17    EQU  $                 R7 contains offset into nudtab
       ANDI R7,>7FFF          If GPL code, get rid of MSB
       A    @NUDTAB,R7        Add in table address
NUDG05 BL   @SAVREG           Restore GPL pointers
       MOVB R7,@GRMWAX(R13)    Write out new GROM address
       SWPB R7                Bare the LSB
       MOVB R7,@GRMWAX(R13)    Put it out too
       B    @RESET            Go back to GPL interpreter
P17L   JMP  P17
*
* CONTINUE ROUTINE FOR PARSE
*
CONTG  BL   @SETREG           GPL entry-set Basic registers
CONT   MOV  *R9,R6            Get last address from stack
       JGT  CONT10            9900 code if not negative
       MOVB R6,@GRMWAX(R13)    Write out new GROM address
       SWPB R6                Bare the second byte
       MOVB R6,@GRMWAX(R13)    Put it out too
       MOV  R13,R6            Set up to test precedence
CONT10 CB   *R6,R8            Test precedence
       JHE  NUDNDL            Have parsed far enough->return
       SRL  R8,7              Make into table offset
       AI   R8,->B8*2         Minimum token for a LED (*2)
       CI   R8,LTBLEN         Maximum token for a LED (*2)
CONT15 JH   NOLEDL            If outside legal LED range-err
       MOV  @LTAB(R8),R7      Pick up address of LED handler
       CLR  R8                Clear 'CHAT' for getting new
       BL   @PGMCHR           Get next character
B9900  B    *R7               Go to the LED handler
NUDE10 DECT R9                Back up subroutine stack
       INC  R7                Skip over precedence
       JMP  NUDG05            Goto code to return to GPL
NOLEDL B    @NOLED
NUDNDL JMP  NUDND1
* Execute one or more lines of Basic
EXECG  EQU  $                 GPL entry point for execution
       BL   @SETREG           Set up registers
       CLR  @ERRCOD           Clear the return code
       MOVB @PRGFLG,R0        Imperative statement?
       JEQ  EXEC15            Yes, handle it as such
* Loop for each statement in the program
EXEC10 EQU  $
       MOVB @FLAG,R0          Now test for trace mode
       SLA  R0,3              Check the trace bit in FLAG
       JLT  TRACL             If set->display line number
EXEC11 MOV  @EXTRAM,@PGMPTR   Get text pointer
       DECT @PGMPTR           Back to the line # to check
*                              break point
       BL   @PGMCHR           Get the first byte of line #
       STST R0                Save status for breakpnt check
       INC  @PGMPTR           Get text pointer again
       BL   @PGMCHR           Go get the text pointer
       SWPB R8                Save 1st byte of text pointer
       BL   @PGMCHR           Get 2nd byte of text pointer
       SWPB R8                Put text pointer in order
       MOV  R8,@PGMPTR        Set new text pointer
       CLR  R8                Clean up the mess
       SLA  R0,2              Check breakpoint status
       JLT  EXEC15            If no breakpoint set - count
       JNC  BRKPNT            If breakpoint set-handle it
EXEC15 EQU  $                                                  <****************
C3     EQU  $+2               Constant data 3                  <
CB3    EQU  $+3               Constant byte 3                  <
       LIMI 3                 Let interrupts loose             <
C0     EQU  $+2               Constant data 0                  <
       LIMI 0                 Shut down interrupts             <
       CLR  @>83D6            Reset VDP timeout                < CRU
       LI   R12,>24           Load console KBD address in CRU  < KEY
       LDCR @C0,3             Select keyboard section          < SCAN
       LI   R12,6             Read address                     < SECTION
       STCR R0,8              SCAN the keyboard                < MUST
       CZC  @C1000,R0         Shift-key depressed?             < BE
       JNE  EXEC16            No, execute the Basic statement  < PATCHED
       LI   R12,>24           Test column 3 of keyboard        < TO
       LDCR @CB3,3            Select keyboard section          < WORK
       LI   R12,6             Read address                     < ON
       STCR R0,8              SCAN the keyboard                < A
       CZC  @C1000,R0         Shift-C depressed?               < GENEVE
       JEQ  BRKP1L            Yes, so take Basic breakpoint    < COMPUTER
EXEC16 MOV  @PGMPTR,@SMTSRT   Save start of statement
       INCT R9                Get subroutine stack space
       MOV  @EXRTNA,*R9       Save the GPL return address
       BL   @PGMCHR           Now get 1st character of stmt
       JEQ  EXRTN3            If EOL after EOS
EXEC17 JLT  EXEC20            If top bit set->keyword
       B    @NLET             If not->fake a 'LET' stmt
EXEC20 MOV  R8,R7             Save 1st token so can get 2nd
       INC  @PGMPTR           Increment the perm pointer
       MOVB *R10,R8           Read the character
       SRL  R7,7              Convert 1st to table offset
       AI   R7,->AA*2         Check for legal stmt token
       JGT  ERRONE            Not in range -> error
       MOV  @STMTTB(R7),R7    Get address of stmt handler
       JLT  P17L              If top bit set -> GROM code
       B    *R7               If 9900 code, goto it!
EXRTN  BYTE >83               Unused bytes for data constant
CBH65  BYTE >65                since NUDEND skips precedences
       CI   R8,SSEPZ*256      EOS only?
       JEQ  EXEC15            Yes, continue on this line
EXRTN2 MOVB @PRGFLG,R0        Did we execute an imperative
       JEQ  EXEC50            Yes, so return to top-level
       S    @C4,@EXTRAM       No, so goto the next line
       C    @EXTRAM,@STLN     Check to see if end of program
       JHE  EXEC10            No, so loop for the next line
       JMP  EXEC50            Yes, so return to top-level
*
* STMT handler for ::
*
SMTSEP MOVB R8,R8             EOL?
       JNE  EXEC17            NO, there is another stmt
EXRTN3 DECT R9                YES
       JMP  EXRTN2            Jump back into it
* Continue after a breakpoint
CONTIN BL   @SETREG           Set up Basic registers
EXC15L JMP  EXEC15            Continue execution
BRKP1L JMP  BRKPN1
TRACL  JMP  TRACE
* Test for required End-Of-Statement
EOL    MOVB R8,R8             EOL reached?
       JEQ  NUDND1            Yes
       CI   R8,TREMZ*256      Higher then tail remark token?
       JH   ERRONE            Yes, its an error
       CI   R8,ELSEZ*256      Tail, ssep or else?
       JL   ERRONE            No, error
*
* Return from call to PARSE
* (entered from CONT)
*
NUDND1 MOV  *R9,R7            Get the return address
       JLT  NUDE10            If negative - return to GPL
       DECT R9                Back up the subroutine stack
       B    @2(R7)            And return to caller
*      (Skip the precedence word)
NUDEND MOVB R8,R8             Check for EOL
       JEQ  NUDND1            If EOL
NUDND2 CI   R8,STRINZ*256     Lower than a string?
       JL   NUDND4            Yes
       CI   R8,LNZ*256        Higher than a line #?
       JEQ  SKPLN             Skip line numbers
       JL   SKPSTR            Skip string or numeric
NUDND3 BL   @PGMCHR           Read next character
       JEQ  NUDND1            If EOL
       JMP  NUDND2            Continue scan of line
NUDND4 CI   R8,TREMZ*256      Higher than a tail remark?
       JH   NUDND3            Yes
       CI   R8,SSEPZ*256      Lower then stmt sep(else)?
       JL   NUDND3            Yes
       JMP  NUDND1            TREM or SSEP
SKPSTR BL   @PGMCHR
       SWPB R8                Prepare to add
       A    R8,@PGMPTR        Skip it
       CLR  R8                Clear lower byte
SKPS01 BL   @PGMCHR           Get next token
       JMP  NUDEND            Go on
SKPLN  INCT @PGMPTR           Skip line number
       JMP  SKPS01            Go on
*
* Return from "CALL" to GPL
RTNG   BL   @SETREG           Set up registers again
       JMP  NUDND1            And jump back into it!
*************************************************************
* Handle Breakpoints
BRKPNT MOVB @FLAG,R0          Check flag bits
       SLA  R0,1              Check bit 6 for breakpoint
       JLT  EXC15L            If set then ignore breakpoint
BRKPN2 LI   R0,BRKFL
       JMP  EXIT              Return to top-level
BRKPN1 MOVB @FLAG,R0          Move flag bits
       SLA  R0,1              Check bit 6 for breakpoint
       JLT  EXEC16            If set then ignore breakpoint
       JMP  BRKPN2            Bit not set
*
* Error handling from 9900 code
*
ERRSYN EQU  $                 These all issue same message
ERRONE EQU  $
NONUD  EQU  $
NOLED  EQU  $
       LI   R0,ERRSN          *SYNTAX ERROR return code
EXIT   EQU  $
ERR    MOV  R0,@ERRCOD        Load up return code for GPL
* General return to GPL portion of Basic
EXEC50 MOV  @RTNADD,R7        Get return address
       B    @NUDG05           Use commond code to link back
* Handle STOP and END statements
STOP
END    DECT R9                Pop last call to PARSE
       JMP  EXEC50            Jump to return to top-level
* Error codes for return to GPL
ERRSN  EQU  >0003             ERROR SYNTAX
ERROM  EQU  >0103             ERROR OUT OF MEMORY
ERRIOR EQU  >0203             ERROR INDEX OUT OF RANGE
ERRLNF EQU  >0303             ERROR LINE NOT FOUND
ERREX  EQU  >0403             ERROR EXECUTION
* >0004 WARNING NUMERIC OVERFLOW
BRKFL  EQU  >0001             BREAKPOINT RETURN VECTOR
ERROR  EQU  >0005             ON ERROR
UDF    EQU  >0006             FUNCTION REFERENCE
BREAK  EQU  >0007             ON BREAK
CONCAT EQU  >0008             CONCATENATE (&) STRINGS
WARN   EQU  >0009             ON WARNING
* Warning routine (only OVERFLOW)
WARNZZ MOV  @C4,@ERRCOD       Load warning code for GPL
       LI   R11,CONT-2        To optimize for return
* Return to GPL as a CALL
CALGPL INCT R9                Get space on subroutine stack
       MOV  R11,*R9           Save return address
       JMP  EXEC50            And go to GPL
* Trace a line (Call GPL routine)
TRACE  MOV  @C2,@ERRCOD       Load return vector
       LI   R11,EXEC11-2      Set up for return to execute
       JMP  CALGPL            Call GPL to display line #
* Special code to handle concatenate (&)
CONC   LI   R0,CONCAT         Go to GPL to handle it
       JMP  EXIT              Exit to GPL interpeter
*************************************************************
*              NUD routine for a numeric constant           *
* NUMCON first puts pointer to the numeric string into      *
* FAC12 for CSN, clears the error byte (FAC10) and then     *
* converts from a string to a floating point number. Issues *
* warning if necessary. Leaves value in FAC                 *
*************************************************************
NUMCON MOV  @PGMPTR,@FAC12    Set pointer for CSN
       SWPB R8                Swap to get length into LSB
       A    R8,@PGMPTR        Add to pointer to check end
       CLR  @FAC10            Assume no error
       BL   @SAVRE2           Save registers
       LI   R3,GETCH          Adjustment for ERAM in order
       MOVB @RAMFLG,R4         to call CSN
       JEQ  NUMC49
       LI   R3,GETCGR
NUMC49 BL   @CSN01            Convert String to Number
       BL   @SETREG           Restore registers
       C    @FAC12,@PGMPTR    Check to see if all converted
       JNE  ERRONE            If not - error
       BL   @PGMCHR           Now get next char from program
       MOVB @FAC10,R0         Get an overflow on conversion?
       JNE  WARNZZ            Yes, have GPL issue warning
       B    @CONT             Continue the PARSE
*
* ON ERROR, ON WARNING and ON BREAK
ONERR  LI   R0,ERROR          ON ERROR code
       JMP  EXIT              Return to GPL code
ONWARN LI   R0,WARN           ON WARNING code
       JMP  EXIT              Return to GPL code
ONBRK  LI   R0,BREAK          ON BREAK code
       JMP  EXIT              Return to GPL code
*
* NUD routine for "GO"
*
GO     CLR  R3                Dummy "ON" index for common
       JMP  ON30              Merge into "ON" code
*
* NUD ROUTINE FOR "ON"
*
ON     CI   R8,WARNZ*256      On warning?
       JEQ  ONWARN            Yes, goto ONWARN
       CI   R8,ERRORZ*256     On error?
       JEQ  ONERR             Yes, got ONERR
       CI   R8,BREAKZ*256     On break?
       JEQ  ONBRK             Yes, goto ONBRK
*
* Normal "ON" statement
*
       BL   @PARSE            PARSE the index value
       BYTE COMMAZ            Stop on a comma or less
CBH66  BYTE >66               Unused byte for constant
       BL   @NUMCHK           Ensure index is a number
       CLR  @FAC10            Assume no error in CFI
       BL   @CFI              Convert Floating to Integer
       MOVB @FAC10,R0         Test error code
       JNE  GOTO90            If overflow, BAD VALUE
       MOV  @FAC,R3           Get the index
       JGT  ON20              Must be positive
GOTO90 LI   R0,ERRIOR         Negative, BAD VALUE
GOTO95 JMP  ERR               Jump to error handler
ON20   EQU  $                 Now check GO TO/SUB
       CI   R8,GOZ*256        Bare "GO" token?
       JNE  ON40              No, check other possibilities
       BL   @PGMCHR           Yes, get next token
ON30   CI   R8,TOZ*256        "GO TO" ?
       JEQ  GOTO50            Yes, handle GO TO like GOTO
       CI   R8,SUBZ*256       "GO SUB" ?
       JMP  ON50              Merge to common code to test
ON40   CI   R8,GOTOZ*256      "GOTO" ?
       JEQ  GOTO50            Yes, go handle it
       CI   R8,GOSUBZ*256     "GOSUB" ?
ON50   JNE  ERRONE            No, so is an error
       BL   @PGMCHR           Get next token
       JMP  GOSUB2            Goto gosub code
ERR1B  JMP  ERRONE            Issue error message
* NUD routine for "GOSUB"
GOSUB  CLR  R3                Dummy index for "ON" code
* Common GOSUB code
GOSUB2 EQU  $                 Now build a FAC entry
       LI   R1,FAC            Optimize to save bytes
       MOV  R3,*R1+           Save the "ON" index
*                              in case of garbage collection
       MOVB @CBH66,*R1+       Indicate GOSUB entry on stack
       INC  R1                Skip FAC3
       MOV  @PGMPTR,*R1       Save current ptr w/in line
       INCT *R1+              Skip line # to correct place
       MOV  @EXTRAM,*R1       Save current line # pointer
       BL   @VPUSH            Save the stack entry
       MOV  @FAC,R3           Restore the "ON" index
       JMP  GOTO20            Jump to code to find the line
* NUD routine for "GOTO"
GOTO   CLR  R3                Dummy index for "ON" code
* Common (ON) GOTO/GOSUB THEN/ELSE code to fine line
*
* Get line number from program
GOTO20 CI   R8,LNZ*256        Must have line number token
       JNE  ERR1B             Don't, so error
GETL10 BL   @PGMCHR           Get MSB of the line number
       MOVB R8,R0             Save it
       BL   @PGMCHR           Read the character
       DEC  R3                Decrement the "ON" index
       JGT  GOTO40            Loop if not there yet
*
* Find the program line
*
       MOV  @STLN,R1          Get into line # table
       MOVB @RAMFLG,R2        Check ERAM flag to see where?
       JEQ  GOTO31            From VDP, go handle it
       MOV  R1,R2             Copy address
GOT32  C    R1,@ENLN          Finished w/line # table?
       JHE  GOTO34            Yes, so line doesn't exist
       MOVB *R2+,R3           2nd byte match?
       ANDI R3,>7FFF          Reset possible breakpoint
       CB   R3,R0             Compare 1st byte of #, Match?
       JNE  GOT35             Not a match, so move on
       CB   *R2+,R8           2nd byte match?
       JEQ  GOTO36            Yes, line is found!
GOT33  INCT R2                Skip line pointer
       MOV  R2,R1             Advance to next line in table
       JMP  GOT32             Go back for more
GOT35  MOVB *R2+,R3           Skip 2nd byte of line #
       JMP  GOT33             And jump back in
GOTO31 MOVB @R1LB,*R15        Get the data from the VDP
       LI   R2,XVDPRD         Load up to read data
       MOVB R1,*R15           Write out MSB of address
GOTO32 C    R1,@ENLN          Finished w/line # table
       JHE  GOTO34            Yes, so line doesn't exist
       MOVB *R2,R3            Save in temporary place for
*                              breakpoint checking
       ANDI R3,>7FFF          Reset possible breakpoint
       CB   R3,R0             Compare 1st byte of #, Match?
       JNE  GOTO35            Not a match, so move on
       CB   *R2,R8            2nd byte match?
       JEQ  GOTO36            Yes, line is found!
GOTO33 MOVB *R2,R3            Skip 1st byte of line pointer
       AI   R1,4              Advance to next line in table
       MOVB *R2,R3            Skip 1nd byte of line pointer
       JMP  GOTO32            Go back for more
GOTO35 MOVB *R2,R3            Skip 2nd byte of line #
       JMP  GOTO33            And jump back in
GOTO34 LI   R0,ERRLNF         LINE NOT FOUND error vector
       JMP  GOTO95            Jump for error exit
GOTO36 INCT R1                Adjust to line pointer
       MOV  R1,@EXTRAM        Save for execution of the line
       DECT R9                Pop saved link to goto
       B    @EXEC10           Reenter EXEC code directly
GOTO40 BL   @PGMCHR           Get next token
       BL   @EOSTMT           Premature end of statement?
       JEQ  GOTO90            Yes =>BAD VALUE for index
       CI   R8,COMMAZ*256     Comma next ?
       JNE  ERR1C             No, error
GOTO50 BL   @PGMCHR           Yes, get next character
       JMP  GOTO20            And check this index value
ERR1C  JMP  ERR1B             Linking becuase long-distance
ERR51  LI   R0,>0903          RETURN WITHOUT GOSUB
       JMP  GOTO95            Exit to GPL
* NUD entry for "RETURN"
RETURN C    @VSPTR,@STVSPT    Check bottom of stack
       JLE  ERR51             Error -> RETURN WITHOUT GOSUB
       BL   @VPOP             Pop entry
       CB   @CBH66,@FAC2      Check ID for a GOSUB entry
       JNE  RETU30            Check for ERROR ENTRY
*
* Have a GOSUB entry
*
       BL   @EOSTMT           Must have EOS after return
       JNE  RETURN            Not EOS, then error return?
       MOV  @FAC4,@PGMPTR     Get return ptr w/in line
       MOV  @FAC6,@EXTRAM     Get return line pointer
       B    @SKPS01           Go adjust it and get back
* Check ERROR entry
RETU30 CB   @CBH69,@FAC2      ERROR ENTRY?
       JEQ  RETU40            Yes, take care of error entry
       CB   @CBH6A,@FAC2      Subprogram entry?
       JNE  RETURN            No, look some more
       BL   @VPUSH            Push it back. Keep information
       JMP  ERR51             RETURN WITHOUT GOSUB error
*
* Have an ERROR entry
* RETURN, RETURN line #, RETURN or RETURN NEXT follows.
*
RETU40 CLR  R3                In case of a line number
       CI   R8,LNZ*256        Check for a line number
       JEQ  GETL10            Yes, treat like GOTO
       MOV  @FAC4,@PGMPTR     Get return ptr w/in line
       MOV  @FAC6,@EXTRAM     Get return line pointer
       BL   @EOSTMT           EOL now?
       JEQ  BEXC15            Yes, treat like GOSUB rtn.
       CI   R8,NEXTZ*256      NEXT now?
       JNE  ERR1C             No, so its an error
       B    @SKPS01           Yes, so execute next statement
BEXC15 B    @EXEC15           Execute next line
CBH6A  BYTE >6A               Subprogram call stack ID
       EVEN
*************************************************************
*         EOSTMT - Check for End-Of-STateMenT               *
*         Returns with condition '=' if EOS                 *
*           else condition '<>' if not EOS                  *
*************************************************************
EOSTMT MOVB R8,R8             EOL or non-token?
       JEQ  EOSTM1            EOL-return condition '='
       JGT  EOSTM1            Non-token return condition '<>'
       CI   R8,TREMZ*256      In the EOS range (>81 to >83)?
       JH   EOSTM1            No, return condition '<>'
       C    R8,R8             Yes, force condition to '='
EOSTM1 RT
*************************************************************
*         EOLINE - Tests for End-Of-LINE; either a >00 or a *
*                  '!'                                      *
*         Returns with condition '=' if EOL else condition  *
*                  '<>' if not EOL                          *
*************************************************************
EOLINE MOVB R8,R8             EOL?
       JEQ  EOLNE1            Yes, return with '=' set
       CI   R8,TREMZ*256      Set condition on a tall remark
EOLNE1 RT                     And return
SYMB20 LI   R0,UDF            Long distance
       B    @GOTO95
* NUD for a symbol (variable)
PSYM   BL   @SYM              Get symbol table entry
       BL   @GETV             Get 1st byte of entry
       DATA FAC               SYM left pointer in FAC
*
       SLA  R1,1              UDF reference?
       JLT  SYMB20            Yes, special code for it
       BL   @SMB              No, get value space pointer
       CB   @FAC2,@CBH65      String reference?
       JEQ  SYMB10            Yes, special code for it
       BL   @MOVFAC           No, numeric ->copy into FAC
SYMB10 B    @CONT             And continue the PARSE
* Statement entry for IF statement
IF     BL   @PARSE            Evaluate the expression
       BYTE COMMAZ            Stop on a comma
CBH67  BYTE >67               Unused byte for a constant
       BL   @NUMCHK           Ensure the value is a number
       CLR  R3                Create a dummy "ON" index
       CI   R8,THENZ*256      Have a "THEN" token
       JNE  ERR1C             No, error
       NEG  @FAC              Test if condition true i.e. <>0
       JNE  IFZ10             True - branch to the special #
       BL   @PGMCHR           Advance to line number token
       CI   R8,LNZ*256        Have the line # token?
       JNE  IFZ20             No, must look harder for ELSE
       INCT @PGMPTR           Skip the line number
       BL   @PGMCHR           Get next token
IFZ5   CI   R8,ELSEZ*256      Test if token is ELSE
       JEQ  IFZ10             We do! So branch to the line #
       B    @EOL              We don't, so better be EOL
GETL1Z B    @GETL10           Get 1st token of clause
IFZ10  BL   @PGMCHR           Get 1st token of clause
       CI   R8,LNZ*256        Line # token?
       JEQ  GETL1Z            Yes, go there
       BL   @EOSTMT           EOS?
JEQ1C  JEQ  ERR1C             Yes, its an error
       LI   R8,SSEPZ*256      Cheat to do a continue
       DEC  @PGMPTR           Back up to get 1st character
       B    @CONT             Continue on
*
* LOOK FOR AN ELSE CLAUSE SINCE THE CONDITION WAS FALSE
*
IFZ20  LI   R3,1              IF/ELSE pair counter
       BL   @EOLINE           Trap out EOS following THEN/ELSE
       JEQ  JEQ1C             error
IFZ25  CI   R8,ELSEZ*256      ELSE?
       JNE  IFZ27             If not
       DEC  R3                Matching ELSE?
       JEQ  IFZ10             Yes, do it
       JMP  IFZ35             No, go on
IFZ27  CI   R8,IFZ*256        Check for it
       JNE  IFZ28             Not an IF
       INC  R3                Increment nesting level
       JMP  IFZ35              And go on
IFZ28  CI   R8,STRINZ*256     Lower than string?
       JL   IFZ30             Yes
       CI   R8,LNZ*256        Higher or = to a line #
       JEQ  IFZ40             = line #
       JL   IFZ50             Skip strings and numerics
IFZ30  BL   @EOLINE           EOL?
       JEQ  IFZ5              Yes, done scanning
IFZ35  BL   @PGMCHR           Get next character
       JMP  IFZ25               And go on
*
* SKIP LINE #'s
*
IFZ40  INCT @PGMPTR           Skip the line #
       JMP  IFZ35             Go on
*
* SKIP STRINGS AND NUMERICS
*
IFZ50  BL   @PGMCHR           Get # of bytes to skip
       SWPB R8                Swap for add
       A    R8,@PGMPTR        Skip it
       CLR  R8                Clear LSB of R8
       JMP  IFZ35
********************************************************************************
 
       TITL 'PARSES2'
 
*************************************************************
*                   'LET' statement handler                 *
* Assignments are done bye putting an entry on the stack    *
* for the destination variable and getting the source value *
* into the FAC. Multiple assignments are handled by the     *
* stacking the variable entrys and then looping for the     *
* assignments. Numeric assignments pose no problems,        *
* strings are more complicated. String assignments are done *
* by assigning the source string to the last variable       *
* specified in the list and changing the FAC entry so that  *
* the string assigned to the next-to-the-last variable      *
* comes from the permanent string belonging to the variable *
* just assigned.                                            *
* e.g.    A$,B$,C$="HELLO"                                  *
*                                                           *
*         C$-------"HELLO" (source string)                  *
*                                                           *
*         B$-------"HELLO" (copy from CZ's string)          *
*                                                           *
*         A$-------"HELLO" (copy from BZ's string)          *
*************************************************************
NLET   CLR  @PAD0             Counter for multiple assign's
NLET05 BL   @SYM              Get symbol table address
*-----------------------------------------------------------*
* The following code has been taken out for checking is     *
* inserted in SMB             5/22/81                       *
*      BL   @GETV             Get first byte of entry       *
*      DATA FAC               SYM left pointer in FAC       *
*      SLA  R1,1              Test if a UDF                 *
*      JLT  ERRMUV            Is a UDF - so error           *
*-----------------------------------------------------------*
       BL   @SMB              Get value space pointer
       BL   @VPUSH            Push s.t. pointer on stack
       INC  @PAD0             Count the variable
       CI   R8,EQZ*256        Is the token an '='?
       JEQ  NLET10            Yes, go into assignment loop
       CI   R8,COMMAZ*256     Must have a comma now
       JNE  ERR1CZ            Didn't - so error
       BL   @PGMCHR           Get next token
       JGT  NLET05            If legal symbol character
       JMP  ERR1CZ            If not - error
ERRMUV LI   R0,>0D03          MULTIPLY USED VARIABLE
       B    @ERR
NLET10 BL   @PGMCHR           Get next token
       BL   @PARSE            PARSE the value to assign
       BYTE TREMZ             Parse to the end of statement
STCOD2 BYTE >65               Wasted byte (STCODE copy)
* Loop for assignments
NLET15 BL   @ASSG             Assign the value to the symbol
       DEC  @PAD0             One less to assign, done?
       JEQ  LETCON            Yes, branch out
       CB   @FAC2,@STCOD2     String or numeric?
       JNE  NLET15            Numeric, just loop for more
       MOV  R6,@FAC4          Get pointer to new string
       MOV  @ARG,@FAC         Get pointer to last s.t. entry
       JMP  NLET15            Now loop to assign more
LETCON B    @EOL              Yes, continue the PARSE
ERR1CZ B    @ERR1C            For long distance jump
       DATA NONUD             (SPARE)             >80
       DATA NONUD             ELSE                >81
       DATA SMTSEP            ::                  >82
       DATA NUDND1            !                   >83
       DATA IF                IF                  >84
       DATA GO                GO                  >85
       DATA GOTO              GOTO                >86
       DATA GOSUB             GOSUB               >87
       DATA RETURN            RETURN              >88
       DATA NUDEND            DEF                 >89
       DATA NUDEND            DIM                 >8A
       DATA END               END                 >8B
       DATA NFOR              FOR                 >8C
       DATA NLET              LET                 >8D
       DATA >8002             BREAK               >8E
       DATA >8004             UNBREAK             >8F
       DATA >8006             TRACE               >90
       DATA >8008             UNTRACE             >91
       DATA >8016             INPUT               >92
       DATA NUDND1            DATA                >93
       DATA >8012             RESTORE             >94
       DATA >8014             RANDOMIZE           >95
       DATA NNEXT             NEXT                >96
       DATA >800A             READ                >97
       DATA STOP              STOP                >98
       DATA >8032             DELETE              >99
       DATA NUDND1            REM                 >9A
       DATA ON                ON                  >9B
       DATA >800C             PRINT               >9C
       DATA CALL              CALL                >9D
       DATA NUDEND            OPTION              >9E
       DATA >8018             OPEN                >9F
       DATA >801A             CLOSE               >A0
       DATA STOP              SUB                 >A1
       DATA >8034             DISPLAY             >A2
       DATA NUDND1            IMAGE               >A3
       DATA >8024             ACCEPT              >A4
       DATA NONUD             ERROR               >A5
       DATA NONUD             WARNING             >A6
       DATA SUBXIT            SUBEXIT             >A7
       DATA SUBXIT            SUBEND              >A8
       DATA >800E             RUN                 >A9
STMTTB DATA >8010             LINPUT              >AA
NTAB   DATA NLPR              LEFT PARENTHISIS    >B7
       DATA NONUD             CONCATENATE         >B8
       DATA NONUD             SPARE               >B9
       DATA NONUD             AND                 >BA
       DATA NONUD             OR                  >BB
       DATA NONUD             XOR                 >BC
       DATA O0NOT             NOT                 >BD
       DATA NONUD             =                   >BE
       DATA NONUD             <                   >BF
       DATA NONUD             >                   >C0
       DATA NPLUS             +                   >C1
       DATA NMINUS            -                   >C2
       DATA NONUD             *                   >C3
       DATA NONUD             /                   >C4
       DATA NONUD             ^                   >C5
       DATA NONUD             SPARE               >C6
       DATA NSTRCN            QUOTED STRING       >C7
       DATA NUMCON        UNQUOTED STRING/NUMERIC >C8
       DATA NONUD             LINE NUMBER         >C9
       DATA >8026             EOF                 >CA
       DATA NABS              ABS                 >CB
       DATA NATN              ATN                 >CC
       DATA NCOS              COS                 >CD
       DATA NEXP              EXP                 >CE
       DATA NINT              INT                 >CF
       DATA NLOG              LOG                 >D0
       DATA NSGN              SGN                 >D1
       DATA NSIN              SIN                 >D2
       DATA NSQR              SQR                 >D3
       DATA NTAN              TAN                 >D4
       DATA >8036             LEN                 >D5
       DATA >8038             CHRZ                >D6
       DATA >803A             RND                 >D7
       DATA >8030             SEGZ                >D8
       DATA >802A             POS                 >D9
       DATA >802C             VAL                 >DA
       DATA >802E             STR                 >DB
       DATA >8028             ASC                 >DC
       DATA >801C             PI                  >DD
       DATA >8000             REC                 >DE
       DATA >801E             MAX                 >DF
       DATA >8020             MIN                 >E0
       DATA >8022             RPTZ                >E1
NTABLN EQU  $-NTAB
LTAB   DATA CONC              &                   >B8
       DATA NOLED             SPARE               >B9
       DATA O0OR              OR                  >BA
       DATA O0AND             AND                 >BB
       DATA O0XOR             XOR                 >BC
       DATA NOLED             NOT                 >BD
       DATA EQUALS            =                   >BE
       DATA LESS              <                   >BF
       DATA GREATR            >                   >C0
       DATA PLUS              +                   >C1
       DATA MINUS             -                   >C2
       DATA TIMES             *                   >C3
       DATA DIVIDE            /                   >C4
       DATA LEXP              ^                   >C5
LTBLEN EQU  $-LTAB
*************************************************************
*                     Relational operators                  *
* Logical conparisons encode the type of comparison and use *
* common code to PARSE the expression and set the status    *
* bits.                                                     *
*                                                           *
* The types of legal comparisons are:                       *
*                             0 EQUAL                       *
*                             1 NOT EQUAL                   *
*                             2 LESS THAN                   *
*                             3 LESS OR EQUAL               *
*                             4 GREATER THAN                *
*                             5 GREATER THAN OR EQUAL       *
*                                                           *
* This code is saved on the subroutine stack                *
*************************************************************
LESS   LI   R2,2              LESS-THAN code for common rtn
       CI   R8,GTZ*256        Test for '>' token
       JNE  LT10              Jump if not
       DECT R2                Therefore, NOT-EQUAL code
       JMP  LT15              Jump to common
C4     EQU  $+2               Constant 4
GREATR LI   R2,4              GREATER-THEN code for common
LT10   CI   R8,EQZ*256        Test for '=' token
       JNE  LTST01            Jump if '>='
LT15   BL   @PGMCHR           Must be plain old '>' or '<'
       JMP  LEDLE             Jump to test
EQUALS SETO R2                Equal bit for common routine
LEDLE  INC  R2                Sets to zero
LTST01 INCT R9                Get room on stack for code
       MOV  R2,*R9            Save status matching code
       BL   @PSHPRS           Push 1st arg and PARSE the 2nd
       BYTE GTZ               Parse to a '>'
CBH69  BYTE >69               Used in RETURN routine
       MOV  *R9,R4            Get the type code from stack
       DECT R9                Reset subroutine stack pointer
       MOVB @LTSTAB(R4),R12   Get address bias to baranch to
       SRA  R12,8             Right justify
       BL   @ARGTST           Test for matching arguments
       JEQ  LTST20            Handle strings specially
       BL   @SCOMPB           Floating point comparison
LTST15 B    @LTSTXX(R12)      Interpret the status by code
LTSTXX EQU  $
LTSTGE JGT  LTRUE             Test if GREATER or EQUAL
LTSTEQ JEQ  LTRUE             Test if EQUAL
LFALSE CLR  R4                FALSE is a ZERO
       JMP  LTST90            Put it into FAC
LTSTNE JEQ  LFALSE            Test if NOT-EQUAL
LTRUE  LI   R4,>BFFF          TRUE is a minus-one
LTST90 LI   R3,FAC            Store result in FAC
       MOV  R4,*R3+           Exp & 1st byte of manitissa
       CLR  *R3+              ZERO the remaining digits
       CLR  *R3+              ZERO the remaining digits
       CLR  *R3+              ZERO the remaining digits
       JMP  LEDEND            Jump to end of LED routine
LTSTLE JEQ  LTRUE             Test LESS-THAN or EQUAL
LTSTLT JLT  LTRUE             Test LESS-THEN
       JMP  LFALSE            Jump to false
LTSTGT JGT  LTRUE             Test GREATER-THAN
       JMP  LFALSE            Jump to false
* Data table for offsets for types
LTSTAB BYTE LTSTEQ-LTSTXX     EQUAL               (0)
       BYTE LTSTNE-LTSTXX     NOT EQUAL           (1)
       BYTE LTSTLT-LTSTXX     LESS THEN           (2)
       BYTE LTSTLE-LTSTXX     LESS or EQUAL       (3)
       BYTE LTSTGT-LTSTXX     GREATER THEN        (4)
       BYTE LTSTGE-LTSTXX     GREATER or EQUAL    (5)
LTST20 MOV  @FAC4,R10         Pointer to string1
       MOVB @FAC7,R7          R7 = string2 length
       BL   @VPOP             Get LH arg back
       MOV  @FAC4,R4          Pointer to string2
       MOVB @FAC7,R6          R6 = string2 length
       MOVB R6,R5             R5 will contain shorter length
       CB   R6,R7             Compare the 2 lengths
       JLT  CSTR05            Jump if length2 < length1
       MOVB R7,R5             Swap if length1 > length2
CSTR05 SRL  R5,8              Shift for speed and test zero
       JEQ  CSTR20            If ZERO-set status with length
CSTR10 MOV  R10,R3            Current character location
       INC  R10               Increment pointer
       BL   @GETV1            Get from VDP
       MOVB R1,R0             And save for comparison
       MOV  R4,R3             Current char location in ARG
       INC  R4                Increment pointer
       BL   @GETV1            Get from VDP
       CB   R1,R0             Compare the characters
       JNE  LTST15            Return with status if <>
       DEC  R5                Otherwise, decrement counter
       JGT  CSTR10            And loop for each character
CSTR20 CB   R6,R7             Status set by length compare
       JMP  LTST15            Return to do test of status
* ARITHMETIC FUNCTIONS
PLUS   BL   @PSHPRS           Push left arg and PARSE right
       BYTE MINUSZ,0          Stop on a minus!!!!!!!!!!!!!!!
       LI   R2,SADD           Address of add routine
LEDEX  CLR  @FAC10            Clear error code
       BL   @ARGTST           Make sure both numerics
       JEQ  ARGT05            If strings, error
       BL   @SAVREG           Save registers
       BL   *R2               Do the operation
       BL   @SETREG           Restore registers
       MOVB @FAC10,R2         Test for overflow
       JNE  LEDERR            If overflow ->error
LEDEND B    @CONT             Continue the PARSE
LEDERR B    @WARNZZ           Overflow - issue warning
MINUS  BL   @PSHPRS           Push left arg and PARSE right
       BYTE MINUSZ,0          Parse to a minus
       LI   R2,SSUB           Address of subtract routine
       JMP  LEDEX             Common code for the operation
TIMES  BL   @PSHPRS           Push left arg and PARSE right
       BYTE DIVIZ,0           Parse to a divide!!!!!!!!!!!!!
       LI   R2,SMULT          Address of multiply routine
       JMP  LEDEX             Common code for the operation
DIVIDE BL   @PSHPRS           Push left arg and PARSE right
       BYTE DIVIZ,0           Parse to a divide
       LI   R2,SDIV           Address of divide routine
       JMP  LEDEX             Common code for the operation
*************************************************************
* Test arguments on both the stack and in the FAC           *
*      Both must be of the same type                        *
*  CALL:                                                    *
*      BL   @ARGTST                                         *
*      JEQ                    If string                     *
*      JNE                    If numeric                    *
*************************************************************
ARGTST MOV  @VSPTR,R6         Get stack pointer
       INCT R6
       MOVB @R6LB,*R15        Load 2nd byte of stack address
       NOP                    Kill some time
       MOVB R6,*R15           Load 1st byte of stack address
       NOP                    Kill some time
       CB   @XVDPRD,@CBH65    String in operand 1?
       JNE  ARGT10            No, numeric
       CB   @FAC2,@CBH65      Yes, is other the same?
       JEQ  ARGT20            Yes, do string comparison
ARGT05 B    @ERRT             Data types don't match
NUMCHK
ARGT10 CB   @FAC2,@CBH65      2nd operand can't be string
       JEQ  ARGT05            If so, error
ARGT20 RT                     Ok, so return with status
* VPUSH followed by a PARSE
PSHPRS INCT R9                Get room on stack
       CI   R9,STKEND         Stack full?
       JH   VPSH27            Yes, error
       MOV  R11,*R9           Save return on stack
       LI   R11,P05           Optimize for the parse
* Stack VPUSH routine
VPUSH  LI   R0,8              Pushing 8 byte entries
       A    R0,@VSPTR         Update the pointer
       MOV  @VSPTR,R1         Now get the new pointer
       MOVB @R1LB,*R15        Write new address to VDP chip
       ORI  R1,WRVDP          Enable the write
       MOVB R1,*R15           Write 1st byte of address
       LI   R1,FAC            Source is FAC
VPSH15 MOVB *R1+,@XVDPWD      Move a byte
       DEC  R0                Decrement the count, done?
       JGT  VPSH15            No, more to move
       MOV  R11,R0            Save the return address
       CB   @FAC2,@CBH65      Pushing a string entry?
       JNE  VPSH20            No, so done
       MOV  @VSPTR,R6         Entry on stack
       AI   R6,4              Pointer to the string is here
       MOV  @FAC,R1           Get the string's owner
       CI   R1,>001C          Is it a tempory string?
       JNE  VPSH20            No, so done
VPSH19 MOV  @FAC4,R1          Get the address of the string
       JEQ  VPSH20            If null string, nothing to do
       BL   @STVDP3           Set the backpointer
VPSH20 MOV  @VSPTR,R1         Check for buffer-zone
C16    EQU  $+2
       AI   R1,16             Correct by 16
       C    R1,@STREND        At least 16 bytes between stack
*                              and string space?
       JLE  VPOP18            Yes, so ok
       INCT R9                No, save return address
       MOV  R0,*R9             on stack
       BL   @COMPCT           Do the garbage collection
       MOV  *R9,R0            Restore return address
       DECT R9                Fix subroutine stack pointer
       MOV  @VSPTR,R1         Get value stack pointer
       AI   R1,16             Buffer zone
       C    R1,@STREND        At least 16 bytes now?
       JLE  VPOP18            Yes, so ok
VPSH23 LI   R0,ERROM          No, so MEMORY FULL error
VPSH25 BL   @SETREG           In case of GPL call
       B    @ERR
VPSH27 B    @ERRSO            STACK OVERFLOW
* Stack VPOP routine
VPOP   LI   R2,FAC            Destination in FAC
       MOV  @VSPTR,R1         Get stack pointer
       C    R1,@STVSPT        Check for stack underflow
       JLE  VPOP20            Yes, error
       MOVB @R1LB,*R15        Write 2nd byte of address
       LI   R0,8              Popping 8 bytes
       MOVB R1,*R15           Write 1st byte of address
       S    R0,@VSPTR         Adjust stack pointer
VPOP10 MOVB @XVDPRD,*R2+      Move a byte
       DEC  R0                Decrement the counter, done?
       JGT  VPOP10            No, finish the work
       MOV  R11,R0            Save return address
       CB   @FAC2,@CBH65      Pop a string?
       JNE  VPOP18            No, so done
       CLR  R6                For backpointer clear
       MOV  @FAC,R3           Get string owner
       CI   R3,>001C          Pop a temporary?
       JEQ  VPSH19            Yes, must free it
       BL   @GET1             No, get new pointer from s.t.
       MOV  R1,@FAC4          Set new pointer to string
VPOP18 B    *R0               And return
VPOP20 LI   R0,ERREX          * SYNTAX ERROR
       JMP  VPSH25
* The returned status reflects the character
* RAMFLG = >00   | No ERAM or imperative statements
*          >FF   | With ERAM and a program is being run
PGMCHR MOVB @RAMFLG,R8        Test ERAM flag
       JNE  PGMC10            ERAM and a program is being run
* Next label is for entry from SUBPROG.
PGMSUB MOVB @PGMPT1,*R15      Write 2nd byte of address
       LI   R10,XVDPRD        Read data address
       MOVB @PGMPTR,*R15      Write 1st byte of address
       INC  @PGMPTR           Increment the perm pointer
       MOVB *R10,R8           Read the character
       RT                     And return
PGMC10 MOV  @PGMPTR,R10
       INC  @PGMPTR
       MOVB *R10+,R8          Write 2nd byte of a address
       RT
********************************************************************************
       AORG >6C9A
       TITL 'GETPUTS'

* (VDP to VDP) or (RAM to RAM) 
* GET,GET1          : Get two bytes of data from VDP
*                   : R3 : address in VDP
*                   : R1 : where the one byte data stored
* PUT1              : Put two bytes of data into VDP
*                   : R4 : address on VDP
*                   : R1 : data
* GETG,GETG2        : Get two bytes of data from ERAM
*                   : R3 : address on ERAM
*                   : R1 : where the two byte data stored
* PUTG2             : Put two bytes of data into ERAM
*                   : R4 : address on ERAM
*                   : R1 : data
* PUTVG1            : Put one byte of data into ERAM
*                   : R4 : address in ERAM
*                   : R1 : data
 
* Get two bytes from RAM(R3) into R1
GET    MOV  *R11+,R3
       MOV  *R3,R3
GET1   MOVB @R3LB,*R15
       MOVB R3,*R15
       NOP
       MOVB @XVDPRD,R1
       MOVB @XVDPRD,@R1LB
       RT
* Put two bytes from R1 to RAM(R4)
PUT1   MOVB @R4LB,*R15
       ORI  R4,WRVDP
       MOVB R4,*R15
       NOP
       MOVB R1,@XVDPWD
       MOVB @R1LB,@XVDPWD
       RT
* Get two bytes from ERAM(R3) to R1
GETG   MOV  *R11+,R3
       MOV  *R3,R3
GETG2  EQU  $
       MOVB *R3+,R1
       MOVB *R3,@R1LB
       DEC  R3
       RT
* Put two bytes from R1 to ERAM(R4)
PUTG2  EQU  $
       MOVB R1,*R4+
       MOVB @R1LB,*R4
       DEC  R4                Preserve R4
       RT
********************************************************************************
 
       AORG >6CE2
       TITL 'NUD359'
 
LEXP   CB   @FAC2,@CBH63      Must have a numeric
       JH   ERRSNM            Don't, so error
       BL   @PSHPRS           Push 1st and parse 2nd
       BYTE EXPONZ,0          Up to another wxpon or less
       BL   @STKCHK           Make sure room on stack
       LI   R2,PWRZZ          Address of power routine
       JMP  COMM05            Jump into common routine
* ABS
NABS   CI   R8,LPARZ*256      Must have a left parenthesis
       JNE  SYNERR            If not, error
       BL   @PARSE            Parse the argument
       BYTE ABSZ              Up to another ABS
CBH63  BYTE >63               Use the wasted byte
       CB   @FAC2,@CBH63      Must have numeric arg
       JH   ERRSNM            If not, error
       ABS  @FAC              Take the absolute value
BCONT  B    @CONT             And continue
* ATN
NATN   LI   R2,ATNZZ          Load up arctan address
       JMP  COMMON            Jump into common rountine
* COS
NCOS   LI   R2,COSZZ          Load up cosine address
       JMP  COMMON            Jump into common routine
* EXP
NEXP   LI   R2,EXPZZ          Load up exponential address
       JMP  COMMON            Jump into common routine
* INT
NINT   LI   R2,GRINT          Load up greatest integer address
       JMP  COMMON            Jump into common routine
* LOG
NLOG   LI   R2,LOGZZ          Load up logarithm code
       JMP  COMMON            Jump to common routine
* SGN
NSGN   CI   R8,LPARZ*256      Must have left parenthesis
       JNE  SYNERR            If not, error
       BL   @PARSE            Parse the argument
       BYTE SGNZ,0            Up to another SGN
       CB   @FAC2,@CBH63      Must have a numeric arg
       JH   ERRSNM            If not, error
       LI   R4,>4001          Floating point one
       MOV  @FAC,R0           Check status
       JEQ  BCONT             If 0, return 0
       JGT  BLTST9            If positive, return +1
       B    @LTRUE            If negative, return -1
BLTST9 B    @LTST90           Sets up the FAC w/R4 and 0s
ERRSNM B    @ERRT             STRING-NUMBER MISMATCH
SYNERR B    @ERRONE           SYNTAX ERROR
* SIN
NSIN   LI   R2,SINZZ          Load up sine address
       JMP  COMMON            Jump into common routine
* SQR
NSQR   LI   R2,SQRZZ          Load up square-root address
       JMP  COMMON            Jump into common routine
* TAN
NTAN   LI   R2,TANZZ          Load up tangent address
COMMON BL   @STKCHK           Make sure room on stacks
       CI   R8,LPARZ*256      Must have left parenthesis
       JNE  SYNERR            If not, error
       INCT R9                Get space on subroutine stack
       MOV  R2,*R9            Put address of routine on stack
       BL   @PARSE            Parse the argument
       BYTE >FF,0             To end of the arg
       MOV  *R9,R2            Get address of function back
       DECT  R9               Decrement subroutine stack
COMM05 CB   @FAC2,@CBH63      Must have a numeric arg
       JH   ERRSNM            If not, error
       CLR  @FAC10            Assume no error or warning
       BL   @SAVREG           Save Basic registers
       MOV  R2,@PAGE2         Select page 2
       BL   *R2               Evaluate the function
       MOV  R2,@PAGE1         Reselect Page 1
       BL   @SETREG           Set registers up again
       MOVB @FAC10,R0         Check for error or warning
       JEQ  BCONT             If not error, continue
       SRL  R0,9              Check for warning
       JEQ  PWARN             Warning, issue it
       LI   R0,>0803          BAD ARGUMENT code
       B    @ERR
PWARN  B    @WARNZZ           Issue the warning message
STKCHK CI   R9,STND12         Enough room on the subr stack?
       JH   BSO               No, memory full error
       MOV  @VSPTR,R0         Get the value stack pointer
       AI   R0,48             Buffer-zone of 48 bytes
       C    R0,@STREND        Room between stack & strings
       JL   STKRTN            Yes, return
       INCT R9                Get space on subr stack
       MOV  R11,*R9+          Save return address
       MOV  R2,*R9+           Save COMMON function code
       MOV  R0,*R9            Save v-stack pointer+48
       BL   @COMPCT           Do a garbage collection
       C    *R9,@STREND       Enough space now?
       JHE  BMF               No, MEMORY FULL error
       DECT R9                Decrement stack pointer
       MOV  *R9,R2            Restore COMMON function code
       DECT R9                Decrement stack pointer
RETRN  MOV *R9,R11            Restore return address
       DECT R9                Decrement stack pointer
STKRTN RT
BMF    B    @VPSH23           * MEMORY FULL
BSO    B    @ERRSO            * STACK OVERFLOW
*************************************************************
* LED routine for AND, OR, NOT, and XOR                     *
*************************************************************
O0AND  BL   @PSHPRS           Push L.H. and PARSE R.H.
       BYTE ANDZ,0            Stop on AND or less
       BL   @CONVRT           Convert both to integers
       INV  @FAC              Complement L.H.
       SZC  @FAC,@ARG         Perform the AND
O0AND1 MOV  @ARG,@FAC         Put back in FAC
O0AND2 BL   @CIF              Convert back to floating
       B    @CONT             Continue
O0OR   BL   @PSHPRS           Push L.H. and PARSE R.H.
       BYTE ORZ,0             Stop on OR or less
       BL   @CONVRT           Convert both to integers
       SOC  @FAC,@ARG         Perform the OR
       JMP  O0AND1            Convert to floating and done
O0NOT  BL   @PARSE            Parse the arg
       BYTE NOTZ,0            Stop on NOT or less
       CB   @FAC2,@CBH63      Get a numeric back?
       JH   ERRSN1            No, error
       CLR  @FAC10            Clear for CFI
       BL   @CFI              Convert to Integer
       MOVB @FAC10,R0         Check for an error
       JNE  SYNERR            Error
       INV  @FAC              Perform the NOT
       JMP  O0AND2            Convert to floating and done
O0XOR  BL   @PSHPRS           Push L.H. and PARSE R.H.
       BYTE XORZ,0            Stop on XOR or less
       BL   @CONVRT           Convert both to integer
       MOV  @ARG,R0           Get R.H. into register
       XOR  @FAC,R0           Do the XOR
       MOV  R0,@FAC           Put result back in FAC
       JMP  O0AND2            Convert and continue
*************************************************************
* NUD for left parenthesis                                  *
*************************************************************
NLPR   CI   R8,RPARZ*256      Have a right paren already?
       JEQ  ERRSY1            If so, syntax error
       BL   @PARSE            Parse inside the parenthesises
       BYTE LPARZ,0           Up to left parenthesis or less
       CI   R8,RPARZ*256      Have a right parenthesis now?
       JNE  ERRSY1            No, so error
       BL   @PGMCHR           Get next token
BCON1  B    @CONT             And continue
*************************************************************
* NUD for unary minus                                       *
*************************************************************
NMINUS BL   @PARSE            Parse the expression
       BYTE MINUSZ,0          Up to another minus
       NEG  @FAC              Make it negative
NMIN10 CB   @FAC2,@CBH63      Must have a numeric
       JH   ERRSN1            If not, error
       JMP  BCON1             Continue
*************************************************************
* NUD for unary plus                                        *
*************************************************************
NPLUS  BL   @PARSE            Parse the expression
       BYTE PLUSZ,0
       JMP  NMIN10            Use common code
*************************************************************
* CONVRT - Takes two arguments, 1 form FAC and 1 from the   *
*          top of the stack and converts them to integer    *
*          from floating point, issuing appropriate errors  *
*************************************************************
CONVRT INCT R9
       MOV  R11,*R9           SAVE RTN ADDRESS
       BL   @ARGTST           ARGS MUST BE SAME TYPE
       JEQ  ERRSN1            AND NON-STRING
       CLR  @FAC10            FOR CFI ERROR CODE
       BL   @CFI              CONVERT R.H. ARG
       MOVB @FAC10,R0         ANY ERROR OR WARNING?
       JNE  ERRBV             YES
       MOV  @FAC,@ARG         MOVE TO GET L.H. ARG
       BL   @VPOP             GET L.H. BACK
       BL   @CFI              CONVERT L.H.
       MOVB @FAC10,R0         ANY ERROR OR WARNING?
       JEQ  RETRN             No, get rtn off stack and rtn
*                             Yes, issue error
ERRBV  B    @GOTO90           BAD VALUE
ERRSN1 B    @ERRT             STRING NUMBER MISMATCH
ERRSY1 B    @ERRONE           SYNTAX ERROR
********************************************************************************
       AORG >6ED6
       TITL 'SPEEDS'
 
 
BSYNCH B    @SYNCHK
BERSYN B    @ERRSYN
BERSNM B    @ERRT
SPEED  MOVB *R13,R0           Read XML code
       SRL  R0,8              Shift for word value
       JEQ  BSYNCH            0 is index for SYNCHK
       DEC  R0                Not SYNCHK, check further
       JEQ  PARCOM            1 is index for PARCOM
       DEC  R0                Not PARCOM, check further
       JEQ  RANGE             2 is index for RANGE
* All otheres assumed to be SEETWO
*************************************************************
* Find the line specified by the number in FAC              *
* Searches the table from low address (high number) to      *
*  high address (low number).                               *
*************************************************************
SEETWO LI   R10,SET           Assume number will be found
       LI   R7,GET1           Assume reading from the VDP
       MOVB @RAMTOP,R0        But correct
       JEQ  SEETW2               If
       LI   R7,GETG2              ERAM is present
SEETW2 MOV  @ENLN,R3          Get point to start from
       AI   R3,-3             Get into table
SEETW4 BL   *R7               Read the number from table
       ANDI R1,>7FFF          Throw away possible breakpoint
       C    R1,@FAC           Match the number needed?
       JEQ  SEETW8            Yes, return with condition set
       JH   SEETW6            No, and also passed it =>return
       AI   R3,-4             No, but sitll might be there
       C    R3,@STLN          Reached end of table?
       JHE  SEETW4            No, so check further
       MOV  @STLN,R3          End of table, default to last
SEETW6 LI   R10,RESET         Indicate not found
SEETW8 MOV  R3,@EXTRAM        Put pointer in for GPL
       B    *R10              Return with condition
RANGE  MOV  R11,R12           Save return address
       CB   @FAC2,@CBH63      Have a numeric
       JH   BERSNM            Otherwise string number mismatch
       CLR  @FAC10            Assume no conversion error
       BL   @CFI              Convert from float to integer
       MOVB @FAC10,R0         Get an error?
       JNE  RANERR            Yes, indicate it
       MOVB *R13,R0           Read lower limit
       SRL  R0,8              Shift for word compare
       MOVB *R13,R1           Read 1st byte of upper limit
       SWPB R1                Kill time
       MOVB *R13,R1           Read 2nd byte of upper limit
       SWPB R1                Restore upper limit
       MOV  @FAC,R2           Get the value
       JLT  RANERR            If negative, error
       C    R2,R0             Less then low limit?
       JLT  RANERR            Yes, error
       C    R2,R1             Greater then limit?
       JH   RANERR            Yes, error
       B    *R12              All ok, so return
RANERR BL   @SETREG           Set up registers for error
       B    @GOTO90           * BAD VALUE
* Make sure at a left parenthesis
LPAR   CB   @CHAT,@LBLPZ      At a left parenthesis
       JNE  BERSYN            No, syntax error
* Parse up to a comma and insure at a comma
PARCOM BL   @PUTSTK           Save GROM address
       BL   @SETREG           Set up R8/R9
       BL   @PARSE            Parse the next item
       BYTE COMMAZ            Up to a comma
LBLPZ  BYTE LPARZ
       CI   R8,COMMAZ*256     End on a comma?
       JNE  BERSYN            No, syntax error
       BL   @PGMCHR           Yes, get character after it
       BL   @SAVREG           Save R8/R9 for GPL
       BL   @GETSTK           Restore GROM address
       B    @RESET            Return to GPL reset
********************************************************************************
       AORG >6F98
       TITL 'MVUPS'

* (RAM to RAM) 
* WITH ERAM    : Move the contents in ERAM FROM a higher
*                 address to a lower address
*                ARG    : byte count
*                VAR9   : source address
*                VAR0   : destination address
 
MVUP   MOV  @ARG,R1           Get byte count
       MOV  @VAR9,R3          Get source
       MOV  @VAR0,R5          Get destination
MVUP05 MOVB *R3+,*R5+         Move a byte
       DEC  R1                Decrement the counter
       JNE  MVUP05            Loop if more to move
       RT
********************************************************************************
 
       AORG >6FAC
       TITL 'GETNBS'
 
* Get a non-space character
GETNB  MOV  R11,R0            Save return address
GETNB1 BL   @GETCHR           Get next character
       CI   R1,' '*256        Space character?
       JEQ  GETNB1            Yes, get next character
       B    *R0               No, return character condition
* Get the next character
GETCHR C    @VARW,@VARA       End of line?
       JH   GETCH2            Yes, return condition
       MOVB @VARW1,*R15       No, write LSB of VDP address
       LI   R1,>A000          Negative screen offset (->60)
       MOVB @VARW,*R15        Write MSB of VDP address
       INC  @VARW             Increment read-from pointer
       AB   @XVDPRD,R1        Read and remove screen offset
       CI   R1,>1F00          Read an edge character?
       JEQ  GETCHR            Yes, skip it
       RT                     Return
GETCH2 CLR  R1                Indicate end of line
       RT                     Return
*-----------------------------------------------------------*
* Remove this routine from CRUNCH because CRUNCH is running *
* out of space                5/11/81                       *
*-----------------------------------------------------------*
*      Calculate and put length of string/number into       *
*      length byte                                          *
LENGTH MOV  R11,R3            Save retun address
       MOV  @RAMPTR,R0        Save current crunch pointer
       MOV  R0,R8             Put into r8 for PUTCHR below
       S    R5,R8             Calculate length of string
       DEC  R8                RAMPTR is post-incremented
       MOV  R5,@RAMPTR        Address of length byte
       BL   @PUTCHR           Put the length in
       MOV  R0,@RAMPTR        Restore crunch pointer
       B    *R3               And return
* FILL IN BYTES OF MODULE WITH COPY OF ORIGINAL?
       DATA >0000
       DATA >EF71             ?????
********************************************************************************
       AORG >7000
       TITL 'FORNEXTS'
 
*************************************************************
* FOR statement                                             *
* Builds up a stack entry for the FOR statement. Checks the *
* syntax of a FOR statement and also checks to see if the   *
* loop is executed at all. The loop is not executed if the  *
* limit of the FOR is > then initial value and the step is  *
* positive of the limit of the FOR is < then initial value  *
* and the step is negative.                                 *
*                                                           *
* A stack entry for a 'FOR' statement looks like:           *
*                                                           *
* +-------------------------------------------------------+ *
* | PTR TO S.T. | >67 |     | Value Space  | BUFLEV       | *
* |   ENTRY     |     |     |  Pointer     |              | *
* | ------------------------------------------------------| *
* | FOR line #  | FOR line  |                             | *
* | table ptr   |  pointer  |                             | *
* |-------------------------------------------------------| *
* |                    Increment Value                    | *
* |-------------------------------------------------------| *
* |                        Limit                          | *
* +-------------------------------------------------------+ *
*************************************************************
NFOR   MOVB R8,R8             EOL?
       JGT  NFOR1             If symbol name, ok
       JMP  ERRCDT            If EOL or Token, error
NFOR1  BL   @SYM              Get pointer to s.t. entry
       BL   @GETV             Get 1st byte of symbol
       DATA FAC                 entry
*
       ANDI R1,>C700          Check string, function & array
       JNE  BERMUW            If andy of the above, error
       CI   R8,EQZ*256        Must have '='
       JNE  ERRCDT            If not, error
       BL   @SMB              Get index's value space
       CLR  @FAC2             Dummy entry ID on the stack
       MOV  @BUFLEV,@FAC6     Save buffer level
*
* Search stack for another FOR entry with the same loop
*  variable. If one is found, remove it.
*
       MOV  @VSPTR,R3         Copy stack pointer
*
* See if end of stack
NFOR1A C    R3,@STVSPT        Check stack underflow
       JLE  NFOR1E            Finished with stack scan
* See if FOR entry
       BL   @GET1             Get pointer to s.t. entry
       MOV  R1,R0             Move it to use later
       MOVB @XVDPRD,R1        Read stack ID
       CB   R1,@CBH67         Is stack entry a FOR?
       JNE  NFOR1B            No, 8 byte regular entry
* Compare loop variables
       C    R0,@FAC           Loop variables match?
       JEQ  NFOR1C            Yes
       AI   R3,-32            Skip this FOR entry
       JMP  NFOR1A            Loop
NFOR1B CB   R1,@CCBH6A        Hit a subprogram entry?
       JEQ  NFOR1E            Yes, don't scan anymore
       AI   R3,-8             Skip 8 byte stack entry
       JMP  NFOR1A            Loop
* Found matching loop variable, move stack down 32 bytes
NFOR1C MOV  @VSPTR,R2         Copy stack pointer
       S    R3,R2             Calculate # of bytes to move
       JEQ  NFOR1D            0 bytes, skip move
       MOV  R3,R4             Destination pointer
       AI   R4,-24            Place to move to
C8     EQU  $+2
       AI   R3,8              Point at entry above FOR entry
NFOR1F BL   @GETV1            Get the byte
       BL   @PUTV1            Put the byte
       INC  R3                Inc From pointer
       INC  R4                Inc To pointer
       DEC  R2                Decrement counter
       JNE  NFOR1F            Loop if not done
NFOR1D S    @C32,@VSPTR       Adjust top of stack
* Now put new FOR entry on stack
NFOR1E BL   @VPUSH            Reserve space for limit
       BL   @VPUSH               increment,
       BL   @VPUSH                and 2nd info entry
       MOVB @CBH67,@FAC2      FOR ID on stack
       BL   @PGMCHR           Get next character
       BL   @PSHPRS           Push symbol I.D. entry
       BYTE TOZ               Parse the initial value
CCBH63 BYTE >63               Wasted byte (CBH63)
       CI   R8,TOZ*256        TO?
       JNE  ERRCDT            No, error
       BL   @PGMCHR
       BL   @PSHPRS           Push initial and get limit
       BYTE STEPZ
CCBH6A BYTE >6A               Wasted byte (CBA6A)
       CB   @CCBH63,@FAC2     If a string value
       JL   BERR6             Its an error
       S    @C40,@VSPTR
       BL   @VPUSH            Push the limit
       BL   @EOSTMT           At the end of statement?
       JEQ  NFOR2             Yes, default incr to 1
       CI   R8,STEPZ*256      STEP?
       JNE  ERRCDT            No, Its an error
       A    @C32,@VSPTR       Corrrect stack pointer
       BL   @PGMCHR
       BL   @PARSE            Get the increment
       BYTE TREMZ,0
       S    @C32,@VSPTR       Get stack to needed place
       MOV  @FAC,R0           Can't have zero increment
       JEQ  ERRBV2            If 0, its an error
       CB   @CCBH63,@FAC2     Can't have zero increment
       JHE  NFOR3             If numeric, ok
BERR6  B    @ERRT             * STRING NUMBER MISMATCH
BERMUW B    @ERRMUV           * MULTIPLY USED VARIABLE
ERRBV2 B    @GOTO90
ERRCDT B    @ERRSYN
NFOR2  LI   R0,FAC
       MOV  @FLTONE,*R0+      Put a floating one in
       CLR  *R0+
       CLR  *R0+
       CLR  *R0
NFOR3  BL   @VPUSH            Push the step
       LI   R1,FAC            Optimize to save bytes
       MOV  @EXTRAM,*R1+      Save line # pointer
       MOV  @PGMPTR,*R1       Save ptr w/in the line
       DEC  *R1               Back up so get last character
       BL   @VPUSH            Push it too!
       A    @H16,@VSPTR       Point to initial value
       BL   @VPOP             Get initial value
       BL   @ASSG             Assign it
       A    @C8,@VSPTR        Restore to top of entry
* Check to see if execute loop at all
       BL   @VPOP             Get ptr to value
       BL   @MOVFAC           Get value
       S    @H16,@VSPTR       Point at limit
       BL   @SCOMPB           Compare them
* VSPTR is now below the FOR entry
       STST R4                Save the status
       JEQ  NFOR03            IF =
       MOV  @VSPTR,R3
H16    EQU  $+2
       AI   R3,16
       BL   @GETV1            Check negative step
       JLT  NFOR05            If a decrement
       SLA  R4,1              Check out of limit
       JGT  NFOR07            Out of limit
NFOR03 A    @C32,@VSPTR       Leave the entry on
       B    @CONT     <<<<<<< Result is w/in limit
NFOR05 SLA  R4,1              Check out of limit
       JGT  NFOR03            Result is w/in limit
* Initial value is not within the limit. Therefore, the loop
* is not executed at all. Must skip the code in the body of
* the loop
NFOR07 LI   R3,1              FOR/NEXT pair counter
NFOR09 BL   @EOLINE           Check end of line
       JEQ  NFOR13            Is end of line
       BL   @PGMCHR           Get 1st token on line
NFOR10 CI   R8,NEXTZ*256      If NEXT
       JNE  NFOR11            If not
       DEC  R3                Decrement counter
       JNE  NFOR12            If NOT matching next
       BL   @PGMCHR           Get 1st char of loop variable
* Check is added in SYM       5/26/81
*      JLT  ERRCDT            If token
       BL   @SYM              Get s.t. pointer to check match
       MOV  @VSPTR,R3         Correct to top of entry
C32    EQU  $+2
       AI   R3,32
       BL   @GET1             Get pointer
       C    R1,@FAC           Match?
       JNE  ERRFNN            No match
       B    @CONT             Continue  <<<<<<<< THE WAY
ERRFN  A    @C4,@EXTRAM
ERRFNN LI   R0,>0B03          FOR NEXT NESTING
       B    @ERR
NFOR11 CI   R8,SUBZ*256       Hit a SUB?
       JEQ  ERRFNN            Yes, can't find matching next
       CI   R8,FORZ*256       FOR?
       JNE  NFOR20            No, Check some more
       INC  R3                Increment depth
NFOR20 CI   R8,LNZ*256        Line number token?
       JNE  NFOR30            No, Check some more
       INCT @PGMPTR           Skip the line number
NFOR30 CI   R8,STRINZ*256     String?
       JNE  NFOR12            No, Check end of statement
       BL   @PGMCHR           Yes, get string length
       SWPB R8                Put the length in R8
       A    R8,@PGMPTR        Skip that many length
       CLR  R8                Clear next crunched code
NFOR12 BL   @PGMCHR           Read next crunched code
       BL   @EOSTMT           Check EOS (includes EOL)
       JNE  NFOR20            Check for line # or string
       JMP  NFOR09            Is EOS or EOL
NFOR13 MOVB @PRGFLG,R0        If imperative w/out match
       JEQ  ERRFNN            Its an error
       S    @C4,@EXTRAM       Goto next line
       C    @EXTRAM,@STLN     Hit end of program?
       JL   ERRFN             Yes, can't match the next
       MOV  @EXTRAM,@PGMPTR   Set PGMPTR to get new PGMPTR
       BL   @PGMCHR           Get
       MOVB R8,@PGMPTR         new
       MOVB *R10,@PGMPT1        PGMPTR
       BL   @PGMCHR           Get next line
       BL   @EOSTMT           Check EOS or EOL
       JEQ  NFOR09            Is EOS or EOL
       JMP  NFOR10            Keep looping
* NEXT4 and NEXT2A were moved from in-line to here in an
* effort to make the "normal" path through the NEXT code as
* straight-line as possible.
NEXT4  S    @C24,@VSPTR       LOOP VARIABLES DON'T MATCH
       JMP  NEXT2
NEXT2B BL   @VPUSH            Keep stack information
NEXT2A LI   R0,>0C03            NEXT WITHOUT FOR
       B    @ERR
*************************************************************
* NEXT statement handler - find the matching FOR statement  *
* on the stack, add the increment to the current value of   *
* the index variable and check to see if execute the loop   *
* again. If loop-variable's value is still within bounds,   *
* goto the top of the loop, otherwise, flush the FOR entry  *
* off the stack and continue with the statement following   *
* the NEXT statement.                                       *
*************************************************************
NNEXT  BL   @SYM              GET S.T.   I.D.
*      MOV  @FAC,R4           SYM/FBSYMB leaves value in R4
NEXT2  C    @VSPTR,@STVSPT    CHECK FOR BOTTOM OF STACK
       JLE  NEXT2A            IF AT BOTTOM -> NEXT W/OUT FOR
       BL   @VPOP             GET 'FOR' ENTRY OFF STACK
       CB   @FAC2,@CBH67      CHECK FOR 'FOR' ENTRY
       JNE  NEXT2B            Is not a 'FOR' entry, error
       C    R4,@FAC           CHECK IF MATCHING 'FOR' ENTRY
       JNE  NEXT4             Is not a match, so check more
       MOV  @VSPTR,R3         Check BUFLEV for match
       AI   R3,14             Point at the BUFLEV in stack
       BL   @GET1             Read it
       C    R1,@BUFLEV        SAME LEVEL?
       JNE  ERRFNN            NO, ITS AN ERROR
       S    @C8,@VSPTR
       BL   @MOVFAC           GET INDEX VALUE
       BL   @SAVREG           SAVE BASIC REGISTERS
       BL   @SADD             ADD IN THE INCREMENT
       BL   @SETREG           RESTORE BASIC REGS
       A    @C24,@VSPTR
       BL   @ASSG             SAVE NEW INDEX VALUE
       S    @H16,@VSPTR       POINT TO THE LIMIT
       BL   @SCOMPB           TEST W/IN LIMIT
       STST R4                SAVE RESULT OF COMPARE
       JEQ  NEXT5             IF = DO LAST LOOP
       MOV  @VSPTR,R3         CHECK FOR A DECREMENT
       AI   R3,16             Point at increment/decrement
       BL   @GETV1            Get 1st byte and set condition
       JLT  NEXT6             If was a decrement
       SLA  R4,1              Check if out of limit
       JGT  NEXT8             Out of limit
NEXT5  A    @C32,@VSPTR       Point to 'FOR' I.D. entry
       MOV  @VSPTR,R3         GOTO TOP OF 'FOR' LOOP
       AI   R3,-8             Point to old EXTRAM
       BL   @GET1             Get new EXTRAM
       MOV  R1,@EXTRAM        Put it in
       INCT R3                POINT AT OLD PGMPTR
       BL   @GET1             Get old PGMPTR
       MOV  R1,@PGMPTR        Put it in
       BL   @PGMCHR           Get 1st token in line
NEXT8  B    @CONT             Continue on
* TEST LIMIT FOR DECREMENT
NEXT6  SLA  R4,1              Check if out of limit
       JGT  NEXT5             If within limit, continue
       JMP  NEXT8             Continue PARSE
********************************************************************************
       AORG >72CE
       TITL 'STRINGS'
 
*************************************************************
*                 MEMORY CHECK ROUTINE                      *
* It checks to see if there is enough room to insert a      *
* symbol table entry or a P.A.B. into the VDP between the   *
* static symbol table/PAB area and the dymamic string area. *
* If there is not it attempts to move the string space down *
* (to  lower address) and then insert the needed area       *
* between the two. NOTE: it may invoke COMPCT to do a       *
* garbage collection. If there is not enough space after    *
* COMPCT then issues *MEMORY FULL* message.                 *
*                                                           *
* INPUT:  # of bytes needed in FAC, FAC+1                   *
* USES:   R0, R12 as temporaries as well as R0 - R6 when    *
*         invoking COMPCT                                   *
*************************************************************
MEMCHG BL   @MEMCHK           GPL entry point
       DATA SET               If NOT enough memory
       B    @RESET            If enough memory
MEMCHK MOV  R11,R12           Save return address
       MOV  @FREPTR,R0        GET BEGINNING OF S.T. FREE SPACE
       S    @STRSP,R0         CALCULATE SIZE OF GAP
       C    @FAC,R0           ENOUGH SPACE ALREADY?
       JL   MEMC08            YES - DONE - RTN
       BL   @COMPCT           NO - COMPACITFY STRING SPACE
       MOV  @STREND,R0        GET STRING FREE SPACE
       S    @VSPTR,R0         CALCULATE SIZE OF GAP
       AI   R0,-64            VSPTR OFFSET TOO
       MOV  @FAC,R10          GET TOTAL # NEEDED BACK
       C    R0,R10            ENOUGH ROOM NOW?
       JL   MEMERR            NO - *MEMORY FULL*
*
* Now move the DYNAMIC STRING AREA DOWN IN MEMORY
*
       MOV  @STRSP,R0         CALCULATE # OF BYTES
       MOV  @STREND,R2        Beginning of move address
       S    R2,R0              in the total string space
       S    R10,@STREND       SET FREE PTR(COPY-TO ADDRESS)
       MOV  R0,R0             NO BYTES TO MOVE?
       JEQ  MEMC04            RIGHT
       MOV  R2,R3             ADDRESS FOR GETV
       INC  R3
       MOV  @STREND,R4        ADDRESS FOR PUTV
       INC  R4
MEMC03 BL   @GETV1            GET THE BYTE
       BL   @PUTV1            PUT THE BYTE
       INC  R3                INC THE FROM
       INC  R4                INC THE TO
       DEC  R0                DEC THE COUNT
       JGT  MEMC03            IF NOT DONE
*                             MOVE IT
MEMC04 S    R10,@STRSP        SET NEW STRIG SPACE PTR
*
* NOW FIX UP STRING PTRS
*
       MOV  @STRSP,R0         GET BEGINNING OF STRING SPACE
MEMC05 C    @STREND,R0        FINISHED?
       JHE  MEMC08            YES
       CLR  R1                CLEAR LOWER BYTE
       MOV  R0,R3             FOR GETV
       BL   @GETV1            GET LENGTH BYTE
       SWPB R1                SWAP FOR ADD
       S    R1,R0             POINT AT BEGINNING OF STRING
       MOV  R0,R3             FOR THE GETV1 BELOW
       AI   R3,-3             POINT AT THE BACKPOITER
       BL   @GET1             GET THE BACK POINTER
*                             BOTH BYTES
       MOV  R1,R1             FREE STRING?
       JEQ  MEMC06            YES
       MOV  R0,R6             PTR TO STRING FOR STVDP
       BL   @STVDP            SET FORWARD PTR
MEMC06 AI   R0,-4             NOW POINT AT NEXT LENGTH
       JMP  MEMC05            CONTINUE ON
MEMC08 B    @2(R12)           Return with space allocated
MEMERR MOV  *R12,R12          Pick up error return address
       B    *R12              * MEMORY FULL(prescan time)
ERRMEM B    @VPSH23           * MEMORY FULL(execution tiem)
*************************************************************
* GETSTR - Checks to see if there is enough space in the    *
*          string area to allocate a string, if there is it *
*          allocates it. If there is not it does a garbage  *
*          collection and once again checks to see if there *
*          is enough room. If so it allocates it, if not it *
*          issues a *MEMORY FULL* message.                  *
*                                                           *
* INPUT :  # of bytes needed in @BYTE                       *
* OUTPUT:  Pointer to new string in @SREF                   *
*          Both length bytes in place & zeroed Breakpointer *
*          @STREND points 1st free byte(new)                *
*                                                           *
* USES  :  R0 - R6 Temporaries                              *
*                                                           *
* Note  :  COMPCT allows a buffer zone of 8 stack entries   *
*          above what is there when COMPCT is called. This  *
*          should allow enough space to avoid a collision   *
*          between the string space and the stack. If       *
*          garbage begins to appear in the string space     *
*          that can't be accounted for, the buffer zone     *
*          will be increased.                               *
*************************************************************
GETSTR MOV  @BYTE,R0          GET # OF BYTES NEEDED
       MOV  R11,R12           SAVE RTN ADDRESS
       C    *R0+,*R0+         ADJUST FOR BACKPTR & 2 LENGTHS
*                              (INCREMENT BY 4)
       MOV  @STREND,R1        CHECK IF ENOUGH ROOM
       S    R0,R1             BY ADVANCING THE FREE PTR
       MOV  @VSPTR,R2         GET VALUE STACK PTR
       AI   R2,64             ALLOW BUFFER ZONE
       C    R1,R2             ENOUGH SPACE?
       JH   GETS10            YES, ALL IS WELL
       BL   @COMPCT           NO, COMPACTIFY
       MOV  @VSPTR,R2         GET VALUE STACK POINTER
       AI   R2,64             ALLOW BUFFER ZONE
       MOV  @BYTE,R0          GET # OF BYTES BACK
       C    *R0+,*R0+         INCREMENT BY 4
       MOV  @STREND,R1        GET NEW END OF STRING SPACE
       S    R0,R1             ADVANCE IT
       C    R1,R2             ENOUGH SPACE NOW?
       JLE  ERRMEM            NO, *MEMORY FULL*
GETS10 AI   R0,-4             GET EXACT LENGTH BACK
       MOVB @R0LB,R1          STORE ENTRY LENGTH
       BL   @PUTV             PUT THE ENDING LENGTH
       DATA STREND             BYTE IN THE STRING
       S    R0,@STREND        PT AT FIRST BYTE OF STRING
       MOV  @STREND,@SREF     POINT SREF AT THE STRING
       DEC  @STREND           POINT AT LEADING LENGTH BYTE
       BL   @PUTV             PUT THE LEADING LENGTH BYTE IN
       DATA STREND            THE STRING
       DECT @STREND           POINT AT BACKPOINTER
       CLR  R6                ZERO FOR THE BACKPOINTER
       MOV  @STREND,R1        ADDR OR THE BACKPOINTER
       BL   @STVDP            CLEAR THE BACKPOINTER
       DEC  @STREND           POINT AT 1ST FREE BYTE
       B    *R12              ALL DONE
*************************************************************
* COMPCT - Is the string garbage collection routine. It can *
*          be invoked by GETSTR or MEMCHK. It copies all    *
*          used strings to the top of the string space      *
*          suppressing out all of the unused strings        *
*    INPUT : None                                           *
*    OUTPUT: UPDATED @STRSP AND @STREND                     *
*    USES  : R0-R6 AS TEMPORARIES                           *
*************************************************************
COMPCT MOV  R11,R7            Save rtn address
       MOV  @FREPTR,R0        Get pointer to free space
       MOV  @STRSP,R5         Get pointer to string space
       MOV  R0,@STRSP         Set new string space pointer
       INC  R5                Compensate for decrement
COMP03 DEC  R5                Point at length of string
       C    @STREND,R5        At end of string space?
       JL   COMP05            No, check this string for copy
       MOV  R0,@STREND        Yes, set end of free space
       B    *R7               Return to caller
COMP05 MOV  R5,R2             Copy ptr to end in case moved
       MOV  R5,R3             Copy ptr to end in read length
       BL   @GETV1            Read the length byte
       MOVB R1,R6             Put it in R6 for address
       SRL  R6,8              Need in LSB for word
       S    R6,R5             Point at the string start
       AI   R5,-3             Point at the back pointer
       MOV  R5,R3             Set up for GETV
       BL   @GET1             Get the backpointer
       MOV  R1,R1             Is this string garbage?
       JEQ  COMP03            Yes, just ignore it
* PERTINENT REGISTERS AT THIS POINT
*        R0 - is where the sting will end
*        R6 - # of bytes to be moved(does not)
*             include lengths and backpointer
*        R2 - points at trailing length byte of string
*             to be moved
* IN GENERAL : MOVE (R6) BYTES FROM VDP(R2-R6) TO VDP(R0-R6)
*              VDP(R0-R6) moving backwards i.e. the last
*              byte of the entry is moved first, then the
*              next to the last byte...
       C    *R6+,*R6+         INCR by 4 to include overhead
       MOV  R2,R3             Restore ptr to end of string
       MOV  R0,R4             Get ptr to end of string space
COMP10 BL   @GETV1            Read a byte
       BL   @PUTV1            Write a byte
       DEC  R3                Decrement source pointer
       DEC  R4                Decrement destination pointer
       DEC  R6                Decrement the counter
       JGT  COMP10            Loop if not finished
       ANDI R4,>3FFF          Delete VDP write-enable & reg
       MOV  R4,R0             Set new free space pointer
       INC  R4                Point at backpointer just moved
       MOV  R4,R3             Copy pointer to read it
       BL   @GET1             Get the backpointer
* R1 now contains the address of the forward pointer
       MOV  R3,R6             Address of the string entry
       AI   R6,3              Point at the string itself
* R6 now contains the address of the string
       BL   @STVDP            Reset the forward pointer
       JMP  COMP03            Loop for next string
*************************************************************
* NSTRCN - Nud for string constants                         *
*          Copies the string into the string space and sets *
*          up the FAC with a string entry of the following  *
*          form:                                            *
*                                                           *
* +-------+-----+----+------------+-----------+             *
* | >001C | >65 | XX | Pointer    | Length of |             *
* |       |     |    | to string  | string    |             *
* +-------+-----+----+------------+-----------+             *
* FAC     +2    +3   +4           +6                        *
*************************************************************
NSTRCN SWPB R8
       MOV  R8,@FAC6          Save length
       MOV  R8,@BYTE          For GETSTR
       SWPB R8
       BL   @GETSTR           Get result string
       LI   R0,>001C          Get address of SREF
       LI   R1,FAC            Optimize to save bytes
       MOV  R0,*R1+           Indicate temporary string
       MOVB @CBH65,*R1+       Indicate a string
       MOVB R0,*R1+           Byte is not used
       MOV  @SREF,*R1         Save pointer to string
       MOV  @BYTE,R2          Get number of bytes to copy in
       JEQ  NSTR20            If none to copy
       MOV  *R1,R4            Get pointer to destination
       MOV  @PGMPTR,R3        Get pointer to source
       MOVB @RAMFLG,R0        ERAM or VDP?
       JNE  NSTR10            ERAM
* Get the string from VDP
NSTR05 BL   @GETV1            Get a byte
       BL   @PUTV1            Put a byte
       INC  R3                Next in source
       INC  R4                Next in destination
       DEC  R2                1 less to move
       JNE  NSTR05            If more to move, do it
       JMP  NSTR20            Else if done, exit
NSTR10 MOVB @R4LB,*R15        Write 2nd byte of VDP address
       ORI  R4,WRVDP          Enable VDP write
       MOVB R4,*R15           Write 1st byte of VDP address
NSTR15 MOVB *R3+,@XVDPWD      Move byte from ERAM to VDP
       DEC  R2                1 less to move
       JNE  NSTR15            If ont done, loop for more
NSTR20 A    @FAC6,@PGMPTR     Skip the string
       BL   @PGMCHR           Get character following string
       B    @CONT             And continue on
********************************************************************************
       AORG >74AA
       TITL 'CIFS'
 
*************************************************************
* CIF     - Convert integer to floating                     *
*           Assume that the value in the FAC is an integer  *
*            and converts it into an 8 byte floating point  *
*            value                                          *
*************************************************************
CIF    LI   R4,FAC            Will convert into the FAC
       MOV  *R4,R0            Get integer into register
       MOV  R4,R6             Copy pointer to FAC to clear it
       CLR  *R6+              Clear FAC & FAC+1
       CLR  *R6+              In case had a string in FAC
       MOV  R0,R5             Is integer equal to zero?
       JEQ  CIFRT             Yes, zero result and return
       ABS  R0                Get ABS value of ARG
       LI   R3,>40            Get exponent bias
       CLR  *R6+              Clear words in result that
       CLR  *R6                might not get a value
       CI   R0,100            Is integer less than 100?
       JL   CIF02             Yes, just put in 1st fraction
*                              part
       CI   R0,10000          No, is ARG less then 100^2?
       JL   CIF01             Yes, just 1 division necessary
*                             No, 2 divisions are necessary
       INC  R3                Add 1 to exponent for 1st
       MOV  R0,R1             Put # in low order word for the
*                              divide
       CLR  R0                Clear high order word for the
*                              divide
       DIV  @C100,R0          Divide by the radix
       MOVB @R1LB,@3(R4)  ~@  Move the radix digit in
CIF01  INC  R3                Add 1 to exponent for divide
       MOV  R0,R1             Put in low order for divide
       CLR  R0                Clear high order for divide
       DIV  @C100,R0          Divide by the radix
       MOVB @R1LB,@2(R4)  ~@  Put next radix digit in
CIF02  MOVB @R0LB,@1(R4)  ~@  Put highest order radix digit in
       MOVB @R3LB,*R4         Put exponent in
       INV  R5                Is result positive?
       JLT  CIFRT             Yes, sign is correct
       NEG  *R4               No, make it negative
CIFRT  RT
********************************************************************************
  
       AORG >7502
       TITL 'SUBPROGS'
 
CONTAD DATA >A000             Address of a continue stmt
GPLIST EQU  >A026             GPL subprogram linked list
 
UNQSTZ EQU  >C8               Unquoted string token
 
INUSE  DATA >8000             In-use flag
FNCFLG DATA >4000             User-defined function flag
SHRFLG DATA >2000             Shared-value flag
*
* ERROR CODES
*
ERRSND EQU  >1203             * SUBEND NOT IN SUBPROGRAM
ERRREC EQU  >0F03             * RECURSIVE SUBPROGRAM CALL
ERRIAL EQU  >0E03             * INCORRECT ARGUMENT LIST
ERROLP EQU  >1103             * ONLY LEGAL IN A PROGRAM
 
*************************************************************
* CALL - STATEMENT EXECUTION                                *
* Finds the subprogram specified in the subprogram table,   *
* evaluates and assigns any arguments to the formal         *
* parameters, builds the stack block, and transfers control *
* into the subprogram.                                      *
*  General register usage:                                  *
*     R0 - R6 Temporaries                                   *
*     R7      Pointer into formals in subprogram name entry *
*     R8      Character returned by PGMCHR                  *
*     R9      Subroutine stack                              *
*     R10     Temporary                                     *
*     R11     Return link                                   *
*     R12     Temporary                                     *
*     R13     GROM read-data address                        *
*     R14     Interpreter flags                             *
*     R15     VDP write-address address                     *
*************************************************************
CALL   BL   @PGMCHR           Skip UNQSTZ & get name length
       MOVB R8,@FAC15         Save lengthfor FBS
       MOVB R8,R4             For the copies to be made
       SRL  R4,8               below
       MOV  @PGMPTR,R0        Get pointer to name
       MOVB @RAMFLG,R1        ERAM or VDP?
       JEQ  CALL04            VDP
* ERAM, must copy into VDP
       MOV  R0,R5             Pointer to string in ERAM
       LI   R0,CRNBUF         Destination in VDP
       MOV  R4,R3             Length for this move
       MOVB @R0LB,*R15        Load out the VDP write address
       ORI  R0,WRVDP          Enable the VDP write
       MOVB R0,*R15           Second byte of VDP write
CALL02 MOVB *R5+,@XVDPWD      Move a byte
       DEC  R3                One less byte to move
       JNE  CALL02            Loop if not done
CALL04 A    R4,@PGMPTR        Skip over the name
       LI   R1,FAC            Destination in CPU
       MOVB @R0LB,*R15        Load out VDP read address
       ANDI R0,>3FFF          Kill VDP write-enable
       MOVB R0,*R15           Both bytes
       NOP                    Don't go to fast for it
CALL06 MOVB @XVDPRD,*R1+      Move a byte
       DEC  R4                One less bye to move
       JNE  CALL06            Loop if not done
       MOV  @SUBTAB,R4        Get beginning of subpgm table
       JEQ  SCAL89            If table empty, search in GPL
       BL   @FBS001           Search subprogram table
       DATA SCAL89            If not found, search in GPL
* Pointer to table entry returned in both R4 and FAC
       BL   @PGMCHR           Get next token
       MOV  R4,R3             Duplicate pointer for GETV
       BL   @GETV1            Get flag byte
       JLT  SCAL90            If attempted recursive call
       SLA  R1,1              Check for BASIC/GPL program
       JLT  GPLSU             GPL subprogram
       MOVB @PRGFLG,R11       Imperative call to BASIC sub?
       JNE  SCAL01            No, OK-handle BASIC subprogram
       LI   R0,ERROLP         Can't call a BASIC sub
       JMP  SCAL91              imperatively
*
* Handle a GPL subprogram
*
GPLSU  INCT R9
       MOV  @CONTAD,*R9+      Put address of a cont on stack
       MOV  R13,*R9           Save address for real BASIC
       AI   R3,6              Now set up new environment
       BL   @GET1             Get access address of GPL subpgm
       MOVB R1,@GRMWAX(R13)    Load out the address into GROM
       SWPB R1                Need to kill time here
       MOVB R1,@GRMWAX(R13)    Next byte also
       BL   @SAVREG           Restore registers to GPL
       B    @RESET            And enter the routine
*
* Execute BASIC subprogram
*
SCAL01 EQU  $
*-----------------------------------------------------------*
* Fix "An error happened in a CALL statement keeps its      *
*      in-use flag set" bug.  5/12/81                       *
*  Move the following 3 lines after finishing processing    *
*  the parameter list, before entering the subprogram.      *
*        SRL  R1,1             Restore mode to original form*
*        SOCB @INUSE,R1        Set the in-use flag bit      *
*        BL   @PUTV1           Put the byte back            *
* Save the pointer to table entry for setting in-use flag   *
* later.                                                    *
* $$$$$$$ USE VDP(0374) 2 BYTES AS TEMPRORARY HERE          *
       LI   R4,>0374          R4: address register for PUT1 *
       MOV  R3,R1             R1: data register for PUT1    *
       BL   @PUT1             Save the pointer to table     *
*                              entry in VDP temporary       *
*-----------------------------------------------------------*
       MOV  R3,R12            Save subtable address
       CLR  @FAC2             Indicate non-special entry
       BL   @VPUSH            Push subprogram entry on stack
       MOV  R12,R4            Restore sub table address
       MOV  R4,R7
       AI   R7,6              Point to 1st argument in list
       MOV  R7,R3             Formals' pointer
       BL   @GET1             Check to see if any
       MOV  R1,R1             Any args?
       JEQ  SCAL32            None, jump forward
       CI   R8,LPARZ*256      Must see a left parenthesis
       JNE  SCAL34            If not, error
       JMP  SCAL08            Jump into argument loop
SCAL90 LI   R0,ERRREC         * RECURSIVE SUBPROGRAM CALL
       JMP  SCAL91
SCAL89 LI   R0,>000A          GPL check for DSR subprogram
SCAL91 B    @ERR
SCAL93 JMP  SCAL12            Going down!
SCAL05 BL   @POPSTK           Short stack pop routine
       MOV  @ARG4,R7          To quickly restore R7
       INCT R7                To account for SCAL80
SCAL06 CI   R8,RPARZ*256      Actual list ended?
       JEQ  SCAL30            Actuals all scanned
       CI   R8,COMMAZ*256     Must see a comma then
       JNE  SCAL12            Didn't, so error
* Scan next actual. Check if it is just a name
SCAL08 MOV  @PGMPTR,@ERRCOD   Save text ptr in case of expr
       BL   @PGMCHR           Get next character
       JLT  SCAL40            No, so must be an expression
       MOV  R7,R12            Save formals pointer
       BL   @SYM              Read name & see if recognized
       BL   @GETV             Check function flag
       DATA FAC
       MOV  R12,R7            Restore formals pointer first
       CZC  @FNCFLG,R1        User-defined function?
       JNE  SCAL40            Yes, pass by value
       CI   R8,LPARZ*256      Complex type?
       JNE  SCAL15            No
       BL   @PGMCHR           Check if formal entry
       CI   R8,RPARZ*256      FOO() ?
       JEQ  SCAL14            Yes, handle it as such
       CI   R8,COMMAZ*256     or FOO(,...) ?
       JNE  SCAL35            No, an array element FOO(I...
SCAL10 BL   @PGMCHR           Formal array, scan to end
       BL   @EOSTMT           Check if end-of-statement
       JEQ  SCAL12            Premature end of statement
       CI   R8,COMMAZ*256     Another comma?
       JEQ  SCAL10            Yes, continue on to end
       CI   R8,RPARZ*256      End yet?
       JEQ  SCAL14            Yes, merge in below
SCAL12 B    @ERRONE           * SYNTAX ERROR
SCAL32 B    @SCAL62           Going down!
SCAL30 B    @SCAL60
SCAL34 B    @SCAL88
SCAL35 B    @SCAL50
SCAL37 JMP  SCAL06
*
* Here for Scalers/Arrays by Reference
SCAL14 BL   @PGMCHR           Pass the right parenthesis
SCAL15 CI   R8,COMMAZ*256     Just a name?
       JEQ  SCAL16            Yes
       CI   R8,RPARZ*256      Start an expression?
       JNE  SCAL40            Yes, name starts an expression
SCAL16 BL   @GETV             Get mode of name
       DATA FAC               Ptr to s.t. entry left by SYM
       MOVB R1,R2             Save for check below
       BL   @SCAL80           And fetch next formal info
       MOVB R2,R1             Copy for this check
       ANDI R1,>C700            for the comparison
       MOV  R6,R0             Use a temporary rgister
       ANDI R0,>C700            for the comparison
       C    R1,R0             Must be exact match
       JNE  SCAL34            Else can't pass by reference
       SOC  @SHRFLG,R6        Set the shared symbol flag
       MOVB R6,R1             Load up for PUTV
       MOV  R5,R4             Address to put the flag
       BL   @PUTV1            Set the flag in the s.t. entry
       ANDI R4,>3FFF          Kill VDP write-enable bit
*
* The following section finds actual's value space address
*  and puts it in R1.
*  FAC contains the symbol table's address.
* If actual is NOT shared.......................
*  Symbol table's address+6 will point to the value space
*   except for numeric ERAM cae. In a numeric ERAM case
*   GET1 to get pointer to the ERAM value space.
* If actual is SHARED........................
*  GET1 to get the pointer in symbol table's address+6
*  In a numeric ERAM case, GETG to get the indirect point
*   to the actual's vlaue space pointer after GET1 is call
*
       MOV  @FAC,R1           Ptr to actual s.t. entry
       AI   R1,6              Ptr to actuals value space
       ANDI R6,>8700          Keep info on string or array
       ANDI R2,>2000          Is actual shared?
       JEQ  SCAL23            No, use it
       MOV  R1,R3             Else look further
       BL   @GET1             Get the true pointer
       MOVB R6,R6             Array or string?
       JNE  SCAL24            Yes, both are special cases
       MOVB @RAMTOP,R2        ERAM present?
       JEQ  SCAL24            No ERAM, so skip
* Numeric variable, shared, ERAM.
       MOV  R1,R3             Get ptr to original from ERAM
       BL   @GETG2            Get indirect pointer
       JMP  SCAL24
* Shared bit is NOT on.
SCAL23 MOVB R6,R6             Check for array or string
       JNE  SCAL24            Yes, take what's in there
       MOVB @RAMTOP,R2        ERAM exists?
       JEQ  SCAL24            No
       MOV  R1,R3             Numeric and ERAM case
       BL   @GET1             Get ERAM value space address
*                             R4 pointing to value space of
SCAL24 AI   R4,6               subprogram's symbol table
       MOVB R6,R6             Array or string case?
       JNE  SCAL26            Yes, so just put ptr in VDP
* Here check for ERAM program and if ERAM then copy the
* address of shared value space into corresponding value
* space in ERAM
       MOVB @RAMTOP,R6        Get the ERAM flag
       JEQ  SCAL26            If no ERAM, simple case
       MOV  R1,R6             Keep shared value space address
       MOV  R4,R3             Put ptr in value space in ERAM
       BL   @GET1             Get value space address in ERAM
       MOV  R1,R4             Copy address into R4 for PUTG2
       MOV  R6,R1             Get the value to put in ERAM
       BL   @PUTG2            Write it into ERAM
       JMP  SCAL37            Loop for next argument
SCAL26 BL   @PUT1             Set symbol indirect link
       JMP  SCAL37            And loop for next arg
*
* Here to pass an expression by value
*
SCAL40 MOV  @ERRCOD,@PGMPTR   Restore text pointer
       MOV  R7,@FAC4          Save formals pointer
       CLR  @FAC2             Don't let VPUSH mess up
SCAL42 BL   @PGMCHR           Set up for the parse
* Save formals ptr & SUBTAB ptr and evaluate the expression
       BL   @PSHPRS
       BYTE RPARZ             Stop on an rpar or comma
DCBH6A BYTE >6A               (CBH6A copy)
       BL   @POPSTK           Restore formals pointer
       A    @C16,@VSPTR       But keep it on stack
       BL   @VPUSH            Save parse result
       MOV  @ARG4,R7          Restore formals pointer
       BL   @SCAL80           And fetch next formal's info
       MOV  R5,@FAC           Set up for assignment
       BL   @SMB              Get value space
       S    @C16,@VSPTR       Get to s.t. info
       BL   @VPUSH            Set up for ASSG
       A    @C8,@VSPTR        Get back to parse result
       BL   @VPOP             Get parse result back
       BL   @ASSG             Assign the value to the formal
       B    @SCAL05           And go back for more
*
* Here for array elements
*
SCAL50 DEC  @PGMPTR           Restore text pointer to lpar
       LI   R11,FAC2          Optimize to save
       CLR  *R11+             Don't let VPUSH mess up (FAC2)
       MOV  R7,*R11+          Save formals pointer    (FAC4)
       MOV  @ERRCOD,*R11      For save on stack       (FAC6)
       BL   @VPUSH            Save the info
       LI   R8,LPARZ*256      Load up R8 with the lpar again
       MOV  @FAC,@PAD0        Save ptr to s.t. entry
       BL   @SMB              Check if name or expression
       CI   R8,COMMAZ*256
       JEQ  SCAL54            Name if ended on a comma
       CI   R8,RPARZ*256
       JEQ  SCAL54             or rpar
       BL   @VPOP             Get saved info back
       MOV  @FAC6,@PGMPTR     Else expr, Restore test pointer
       JMP  SCAL42            And handle like an expression
*
* Passing array elements by reference
SCAL54 BL   @POPSTK           Restore symbol pointer
       MOV  @ARG4,R7
       BL   @SCAL80           Get next formal's info
       BL   @GETV             Check actualOs mode
       DATA PAD0              Get back header information
       ANDI R1,>C000          Throw away all but string & function
       CB   R6,R1             Check mode match (string/num)
       JNE  JNE88             Don't, so error
* Can set bit in R1 since MSB (R1)=MSB (R6)
       SOCB @SHRFLG,R1        Set the share flag
       MOV  R5,R4             Address for PUTV
       BL   @PUTV1            Put it in the s.t. entry
       ANDI R4,>3FFF          Kill VDP write, enable bit
       MOV  @FAC,R1           Assuming string, ref link=@FAC
       MOVB R6,R6             Check if it is a string
       JLT  SCAL24            If so, go set ref. link
       MOV  @FAC4,R1          Numeric, ref. link=@FAC4(v.s.)
       JMP  SCAL24            Now set the link and go on
*
* Here when done parsing actuals
*
SCAL60 BL   @PGMCHR           Pass the right parenthesis
SCAL62 BL   @EOSTMT           Must be at end of statement
JNE88  JNE  SCAL88            If not, error
       MOV  R7,R3             Formals must also have ended
       INCT R7
       MOV  R7,@FAC           Keep R7, POPSTK destorys R7
       BL   @GET1             Get the last arg address
       MOV  R1,R1             Formals end?
       JNE  SCAL88            Didn't, so error
*
* Now set up the stack entry
*
       BL   @VPUSH            Check if enough room for push
       S    @C8,@VSPTR        Get back right pointer
       BL   @POPSTK           Retrieve ptr to subprog s.t.
       LI   R12,FAC           For code optimization
       MOV  R12,R1            Store following data in FAC
       MOV  *R12,@ARG2        Save new environment pointer
*
* First push entry. PGMCHR, EXTRAM, SYMTAB and RAM(SYNBOL)
*
       LI   R0,PGMPTR         Optimize
       MOV  *R0+,*R1+         Text pointer         PGMPTR
       MOV  *R0+,*R1+         Line table pointer   EXTRAM
       MOV  @SYMTAB,*R1+      Symbol table pointer
       LI   R3,SYMBOL         Put address of SYMBOL
       BL   @GET1             Get RAM(SYMBOL) in REG1
       MOV  R1,@FAC6          Move to FAC area
       BL   @VPUSH            Save first entry
*
* Push second entry. Subprogram table pointer, >6A on warning
*  bits and @LSUBP in the second stack.
       MOV  R12,R4            Going to build entry in FAC
       MOV  @ARG,*R4+         Subprogram table entry pointer
       MOVB @DCBH6A,*R4+      >6A = Stack ID
       MOVB @FLAG,R2          Warning/break bits
       ANDI R2,>0600          Mask off other bits
       MOVB R2,*R4+           Put bits in stack entry
       MOV  @LSUBP,@FAC6      Last subprogram block on stack
       BL   @VPUSH            Push final entry
       MOV  @VSPTR,@LSUBP     Set bottom of stack for the sub
*
* Now build the new environment by modifying PGMCHR,
* EXTRAM and pointer to sub's symbol table.
       LI   R0,PGMPTR         Optimization
       MOVB @ARG3,*R15        2nd byte of address
       LI   R1,XVDPRD         Optimize to save bytes
       MOVB @ARG2,*R15        1st byte of address
       LI   R4,4              Need 4 bytes
SCAL70 MOVB *R1,*R0+          Read EXTRAM and PGMPTR
       DEC  R4
       JNE  SCAL70
       MOVB *R1,@SYMTAB       New SYMTAB
       LI   R4,SYMBOL
       MOVB *R1,@SYMTA1
       MOV  @SYMTAB,R1
       BL   @PUT1             New RAM(SYMBOL)
       CLR  @ERRCOD           Clean up our mess
       BL   @PGMCHR           Get the next token into R8
*-----------------------------------------------------------*
* Fix "A error happened in a CALL statement keeps it        *
*   "in-use flag set" bug,    5/23/81                       *
* Insert following lines:                                   *
       LI   R3,>0374          Restore the pointer to table  *
*  entry from VDP temporary, R3: address reg. for GET1      *
       BL   @GET1                                           *
       MOV  R1,R3             Get flag byte                 *
       BL   @GETV1                                          *
       SOCB @INUSE,R1         Set the in-use flag bit       *
       MOV  R3,R4             ??????????????????????????????????????????????????
       BL   @PUTV1            Put the byte back             *
*-----------------------------------------------------------*
       B    @NUDEND           Enter the subprogram
SCAL88 LI   R0,ERRIAL         * INCORRECT ARGUMENT LIST
       JMP  $+>C6             Jump to  B @ERR
*************************************************************
* Fetch next formal and prop for adjustment                 *
* Register modification                                     *
*    R5  Address of s.t. entry (formal's entry)             *
*    R6  Header byte of formal's entry                      *
*    R7  Updated formal's pointer                           *
* Destroys: R1, R2, R3, R4, R11, R12                        *
*************************************************************
SCAL80 MOV  R11,R12           Save return address
       MOV  R7,R3             Fetch symbol pointer
       INCT R7                Point to next formal
       BL   @GET1             Fetch s.t. pointer
       MOV  R1,R3             Set condition & put in place
       JEQ  SCAL88            If to many actuals
       MOV  R1,R4             Save for below
       MOV  R1,R5             Save for return
       BL   @GET1             Get header bytes
       COC  @SHRFLG,R1        Shared?
       JEQ  SCAL82            Yes, reset flag and old value
       MOV  R1,R6             Save for return & test string
       JLT  SCAL81            If it is a string, then SCAL81
       B    *R12              Return
SCAL81 AI   R3,6              Is string, point at value ptr
       BL   @GET1             Get the value pointer
       MOV  R1,R4             Null value?
       JEQ  SCAL86            Yes
       CLR  R1                No, must free current string
       AI   R4,-3             Point at the backpointer
       BL   @PUT1             Clear the backpointer
       MOV  R3,R4
SCAL84 CLR  R1                Needed for entry from below
       BL   @PUT1             Clear the forward pointer
       B    *R12              Just return
SCAL82 ANDI R1,>DFFF          Reset the share flag
       BL   @PUTV1            Put it there
       AI   R4,6              Point at ref pointer
       MOV  R1,R6             Set for return
       JLT  SCAL84            If string clear ref pointer
SCAL86 B    *R12              Return
*************************************************************
* Execute a SUBEXIT or SUBEND                               *
*************************************************************
SUBXIT MOV  @LSUBP,R5         Check for subprogram on stack
       JEQ  SCAL98            Not one, so error
       C    R5,@VSPTR         Extra check on stack pointer
       JH   SCAL98            Pointers are messed up, error
SBXT05 BL   @VPOP             Get stack entry
       CB   @FAC2,@DCBH6A     Reached the subprogram entry?
       JNE  SBXT05            Not yet
*
* Reached the subprogram stack entry. Get information FAC
*  area has subprograms table pointer, >6A, on warning bits
*  and LSUBP
       LI   R12,FAC           Optimize for the copies
       MOV  R12,R0            For this copy
       MOV  *R0+,R3           Subprogram pointer
       BL   @GETV1            Get header byte in subprogram
       SZCB @INUSE,R1         Reset the in-use bit
       MOV  R3,R4
       BL   @PUTV1            Put it back
       MOV  *R0+,R1           On warning bits
       MOVB @FLAG,R4          Get the current flag
       ANDI R4,>F900          Trash current warning bits
       SOCB @R1LB,R4          OR the old ones back in
       MOVB R4,@FLAG          And put flag back
       INCT R0                There is one word empty
       MOV  *R0+,@LSUBP       Last subprogram block on stack
*
* Second subprogram stack entry. Restore pointers. FAC area
*  has PGMPTR, EXTRAM, SYMTAB, RAM(SYMBOL)
       BL   @VPOP             Get second entry
       MOV  R12,R0            Put FAC in R0. (optimization)
       LI   R1,PGMPTR         For optimization
       MOV  *R0+,*R1          Restore text pointer    PGMPTR
       DEC  *R1+              Save code to decrement it
       MOV  *R0+,*R1+         Line table pointer EXTRAM
       MOV  *R0+,@SYMTAB      Restore symbol table pointer
       MOV  *R0+,R1           Restore permanent s.t. pointer
       LI   R4,SYMBOL         Place in VDP
       BL   @PUT1             Put it out there
       BL   @PGMCHR           Load R8 with EOS/EOL & go on
       B    @EOL
SCAL98 LI   R0,ERRSND         * SUBEND NOT IN SUBPROGRAM
       B    @ERR
********************************************************************************
 
 
       TITL 'SUBPROGS2'
 
*************************************************************
* RESOLV - Attempt to resolve all subprograms referenced in *
* call statements by first searching the internal subprogram*
* table (SUBTAB), then by searching GROMs for GPL           *
* subprograms. In RESGPL, it builds a subprogram table.     *
* If, after searching all of the subprogram areas, there    *
* are any subprograms whose location cannot be determined,  *
* an error occurs.                                          *
*************************************************************
RESOLV INCT R9                Save return address
       MOV  R11,*R9
       MOV  @CALIST,R5        Pick up call list pointer
       JEQ  RES50             If no subprogram references
RES03  MOV  @SUBTAB,R6        Pick up subprogram table ptr
RES05  JEQ  RES15             Try to resolve by checking
*                                                           *
* Compares two names for a match when trying to resolve all *
*  references to subprograms.                               *
* Register usage is generally as follows:                   *
*         R5  - Pointer to CALIST entry to be compared      *
*         R7  - Pointer to entry to be compared to SUBTAB   *
*               Returns as pointer to name if found or zero *
*                if not found                               *
*         R10 - Returned as length of name                  *
       MOV  R6,R3             Put in place for GETV
       INC  R3                Point at the name length
       BL   @GETV1            Get the name length
       SRL  R1,8              Put in LSB and clear MSB
       MOV  R1,R4             Save it for the move
       AI   R3,3              Point at name pointer
       BL   @GET1             Get the name pointer
       MOV  R1,R7             Save in permanent
       MOV  R1,@PGMPTR        Save for compare
       MOV  R5,R3             To get the CALIST entry
       INC  R3                Point at the name length
       BL   @GETV1            Get the name length
       CB   R1,@R4LB          Name length match?
       JNE  RES20             No, no match possible
       MOV  R4,R0             Save name length for compare
       AI   R3,3              Point at the name pointer
       BL   @GET1             Get the pointer to the name
       MOV  R1,R3             Set up to get the name
COMPTN BL   @GETV1            Get a char of CALIST name
* Next PGMSUB call is the same as PGMCHR except in skipping
*  ERAM check
       BL   @PGMSUB           Get a char of found name
       CB   R1,R8             Chars match?
       JNE  RES20             No, not same name
       INC  R3                Next character
       DEC  R0                Done with compare?
       JNE  COMPTN            No, check the rest
* Found the subprogram in GROM and built the table.
* Set resolved flag and get back.
       MOV  R5,R4             Set resolved flag now
       SETO R1                Set up a resolved flag
       BL   @PUTV1            And put the byte in
RES15  MOV  R5,R3             Get call list pointer
       INCT R3                Point at link
       BL   @GET1             Get the name link
       MOV  R1,R5             Save and set condition
       JEQ  RESGPL            End of call list? Yes
       JNE  RES03             No, go check the next in list
RES20  MOV  R6,R3             Get next entry in subpgm table
       INCT R3                Point at the link
       BL   @GET1             Get the link
       MOV  R1,R6             Update subprogram table pointer
       JMP  RES05             And try next entry
RES50  CLR  R3                Indicate no error return
RES51  MOV  *R9,R11           Restore return address
       DECT R9                Restore stack
       RT                     All resolved and ok
RES52  LI   R3,>001C
       JMP  RES51
*************************************************************
*                   RESGPL routine                          *
* Resolves as a GPL subprogram by comparing names in CALL   *
* list and GROM link list in EXEC. If name found in GROM    *
* then turn the resolved flag on and if not found an error  *
* occurs. Fetch subprogram access address from the link     *
* list and builds a subprogram table for that call.         *
*************************************************************
RESGPL MOV  @CALIST,R5        Get the call list pointer
* Get the next subprogram in the call list that has not been
*  resolved.
GET01  MOV  R5,R3             Get pointer in call list
       JEQ  RES50             If end of list
       BL   @GETV1            Get the resolved flag
       JEQ  GPL00             If not resolved
GET03  INCT R3                Point at link
       BL   @GET1             Get the link
       MOV  R1,R5             Save it and set condition
       JNE  GET01             If not end of list, go on
       JMP  RES50             Return
* Start looking at GROM subprogram link list.
GPL00  LI   R7,GPLIST         Load address of link list
       MOV  R5,R3             Copy CALIST address
       INC  R3                Point to name length
       BL   @GETV1            Get the name length
       SRL  R1,8              Adjust to the right byte
       MOV  R1,R0             Copy for later use
       CLR  R10               Clear for name length
       AI   R3,3              Point to name ptr in call list
GPL10  MOVB R7,@GRMWAX(R13)    Specify address in link list
       SWPB R7                Need to kill time here
       MOVB R7,@GRMWAX(R13)    Move next byte
       SWPB R7                Get R7 in right order
       MOVB *R13,R8           Read next link address from
       MOVB *R13,@R8LB         linked list
       INCT R7                Point to name length in GROM
       MOVB R7,@GRMWAX(R13)    Specify name length address
       SWPB R7                Need to kill time here
       MOVB R7,@GRMWAX(R13)    Move next byte
       SWPB R7                Get R7 in right order
       MOVB *R13,@R10LB       Get the name length in GROM
       C    R0,R10            Compare name length
       JEQ  GPL25             If matches, compare names
GPLNXT MOV  R8,R7             Didn't match, get link to next
       JNE  GPL10             Loop if not end of list
       MOV  R5,R3             If end of GPL list, ignore this
       JMP  GET03              entry in CALIST
* Start comparing the names
GPL25  BL   @GET1             Get name ptr form call list
*                             R1 contains address of name
       MOVB @R1LB,*R15        Get one character from VDP
       NOP
       MOVB R1,*R15           Then compare with the one in
GPL30  CB   *R13,@XVDPRD       GROM - R13 points to GROM
       JNE  GPLNXT            If no match get next in GROM
       DEC  R10               All matched?
       JNE  GPL30             No, loop for next characters
* Found the GPL subprogram. Now start building GPL's
*  subprogram table.
* First put all information in FAC since they might get
*  destroyed in MEMCHK.
* @FAC2  = Set program bit and name length
* @FAC4  = Subprogram table link address
* @FAC6  = Pointer to name
* @FAC8  = Access address in GROM
* @FAC10 = Current call list address
       LI   R12,FAC2          Optimize for speed and space
       MOV  R0,*R12           Keep length in FAC2
       SOC  @FNCFLG,*R12+     Set program bit
       MOV  @SUBTAB,*R12+     Set up subtable link address
       BL   @GET1             Get pointer to name
       MOV  R1,*R12+          Move it to FAC6
       MOVB *R13,*R12+        Get access address from GROM
       NOP
       MOVB *R13,*R12+         and put it in FAC8
       MOV  R5,*R12           Save current call list address
* Check if ERAM exists or imperative statement. If so then
* copy name into appropriate VDP area.
       MOVB @RAMFLG,R6        ERAM present?
       JNE  GPL40             Yes, then save name in table
       MOVB @PRGFLG,R6        Imperative call
       JNE  GPL60             No, handle normally
* Copy name into table area
GPL40  MOV  R0,@FAC           Copy name length
       BL   @MEMCHK           Get the space. FAC = name length
       DATA RES52             Error return address
       MOV  @FAC6,R3          Get pointer to name
       S    @FAC,@FREPTR      New free pointer
       MOV  @FREPTR,R4        New place of name
       INC  R4
       MOV  R4,@FAC6          New pointer to name
       MOV  @FAC,R2           Counter for the move
* Now copy the name, character by character
GPL50  BL   @GETV1            Get a byte
       BL   @PUTV1            Put a byte
       INC  R3
       INC  R4
       DEC  R2                Done?
       JNE  GPL50             No, move the rest
* Restore all the information from FAC area and build
*  subprograms symbol table.
GPL60  MOV  @C8,@FAC          Need 8 bytes
       BL   @MEMCHK           Get the bytes. Check the space
       DATA RES52             Error return address
       S    @C8,@FREPTR       Updata the free pointer
       MOV  @FREPTR,R0        Get location to move to
       INC  R0                True pointer
       MOV  R0,@SUBTAB        Update subprogram table ptr
       LI   R1,FAC2           Subprograms info starts FAC2
       MOVB @R0LB,*R15        Load out address
       ORI  R0,WRVDP          Enable VDP write
       MOVB R0,*R15
       LI   R0,XVDPWD         Optimize to save bytes
       LI   R3,8              Going to move 8 bytes
GPL70  MOVB *R1+,*R0          Copy mode, name length, link,
       DEC  R3                 ptr to name, ptr to subprogram
       JNE  GPL70
       MOV  *R1,R3            Restore ptr into call list
       B    @GET03            Check next entry in call list
********************************************************************************
       AORG >7ADA
       TITL 'SCROLLS'
 
FLG    EQU  5
 
* R12  total number of bytes to move
* R10  move from
* R9   move to
* R8   minor counter (buffer counter)
* R7   buffer pointer
 
SCROLL LI   R12,736           Going to move 736 bytes
       LI   R10,32            Address to move from
       CLR  R9                Address to move to
       MOV  R11,R6            Save return address
       BL   @SCRO1            Scroll the screen
       LI   R5,XVDPWD         Optimize for speed later
       LI   R4,>02E0          Addr of bottom line on screen
       LI   R1,>7F80          Edge character and space char ~~~~~~~~~~~~
       LI   R2,28             28 characters on bottom line
       BL   @PUTV1            Init VDP & put out 1st edge char
       MOVB R1,*R5            Put out 2nd edge character
       SWPB R1                Bare the space character
SCRBOT MOVB R1,*R5            Write out space character
       DEC  R2                One less to move
       JNE  SCRBOT            Loop if more
       SWPB R1                Bare the edge character again
       MOVB R1,*R5            Output edge character
       MOVB R1,*R5            Output edge character
       B    *R6               And return go GPL
* Generalized move routine
SCRO1  CLR  R8                Clear minor counter
       MOVB @R10LB,*R15       Write out LSB of read-address
       STWP R7                Get the WorkSpace pointer
       MOVB R10,*R15          Write out MSB of read-address
SCRO2  MOVB @XVDPRD,*R7+      Read a byte
       INC  R10               Inc read-from address
       INC  R8                Inc minor counter
       DEC  R12               Dec total counter
       JEQ  SCRO4             If all bytes read-write them
       CI   R8,12             Filled WorkSpace buffer area?
       JLT  SCRO2             No, read more
SCRO4  MOVB @R9LB,*R15        Write LSB of write-address
       ORI  R9,WRVDP          Enable the VDP write
       MOVB R9,*R15           Write MSB of write-address
       STWP R7                Get WorkSpace buffer pointer
SCRO6  MOVB *R7+,@XVDPWD      Write a byte
       INC  R9                Increment write-address
       DEC  R8                Decrement counter
       JNE  SCRO6             Move more if not done
       MOV  R12,R12           More on major counter?
       JNE  SCRO1             No, go do another read
       RT                     Yes, done
*************************************************************
* Decode which I/O utility is being called                  *
* Tag field following the XML IO has the following          *
* meaning:                                                  *
*     0 - Line list - utility to search keyword table to    *
*         restore keyword from token                        *
*     1 - Fill space - utility to fill record with space    *
*         when outputting imcomplete records                *
*     2 - Copy string - utility to copy a string, adding    *
*         the screen offset to each character for display   *
*         purposes                                          *
*     3 - Clear ERAM - utility to clear ERAM at the address *
*         specified by the data word following the IO tag   *
*         and the # of bytes specified by the length        *
*         following the address word. Note that each data   *
*         word is the address of a CPU memory location.     *
*************************************************************
IO     MOVB *R13,R0           Read selector from GROM
       SRL  R0,8              Shift for decoding
       JEQ  LLIST             0 is tag for Line list
       DEC  R0
       JEQ  FILSPC            1 is tag for Fill space
       DEC  R0
       JEQ  CSTRIN            2 is tag for Copy string
*                             3 is tag for CLRGRM string
*                                fall into it
* CALGRM
* R1 - address of clearing start
* R2 - number of bytes to clear
CLRGRM LI   R1,PAD0           Get CPU RAM offset
       MOV  R1,R2             Need for next read too
       AB   *R13,@R1LB        Add address of ERAM pointer
       MOV  *R1,R1            Read the ERAM address
       AB   *R13,@R2LB        Read address of byte count
       MOV  *R2,R2            Read the byte count
       CLR  R0                Clear of clearing ERAM
CLRGR1 MOVB R0,*R1+           Clear a byte
       DEC  R2                One less to clear, done?
       JNE  CLRGR1            No, loop for rest
       RT                     Yes, return
* CSTRIN
* R0 - MNUM
* R1 - GETV/PUTV buffer
* R3 - FAC4/GETV address
* R5 - return address
CSTRIN MOV  R11,R5            Save return address
       MOVB @MNUM,R0          Get MNUM
       JEQ  CSTR1O            If no bytes to copy
       SRL  R0,8              Shift to use as counter
       MOV  @CCPADR,R4        Get copy-to address
       MOV  @FAC4,R3          Get copy-from address
CSTRO5 BL   @GETV1            Get byte
       AB   @DSRFLG,R1        Add screen offset
       BL   @PUTV1            Put the offset byte out
       INC  R3                Increment from address
       INC  R4                Increment to address
       DEC  R0                One less to move
       JNE  CSTRO5            Loop if not done
       MOV  R3,@FAC4          Restore for GPL
CSTR07 MOVB R0,@MNUM          Clear for GPL
CCBHFF EQU  $+3
       ANDI R4,>BFFF          Throw away VDP write enable
       MOV  R4,@CCPADR        Restore for GPL
FILSZ6 EQU  $
CSTR1O B    *R5               Return
* FILSPC
* R0 - MNUM
* R1 - Buffer for GETV/PUTV
* R2 - MNUM1
* R3 - Pointer for GETV
* R4 - CCPADR, pointer for PUTV
* R5 - return address
FILSPC MOV  R11,R5            Save return address
       MOVB @MNUM1,R2         Get pointer to end of record
       JNE  FILSZ1            If space to fill for sure
       CB   R2,@CCPPTR        Any filling to do?
       JNE  FILSZ2            Yes, do it normalling
       B    *R5               No, 255 record already full
FILSZ1 CB   R2,@CCPPTR        Any filling to do?
       JLE  FILSZ6            No, record is complete
FILSZ2 SB   @CCPPTR,R2        Compute # of bytes to change
       AB   R2,@CCPPTR        Point to end
       MOVB @DSRFLG,R0        Filling with zeroes?
       JNE  FILSZ3            No, fill with spaces
       MOV  @PABPTR,R3        Check if internal files
       AI   R3,FLG            5 byte offset into PAB
       CLR  R1                Initialize to test below
       BL   @GETV1            Get byte from PAB
       ANDI R1,>0800          Internal?
       JNE  FILSZ4            Yes, zero fill
FILSZ3 AI   R0,>2000          Add space character for filler
FILSZ4 SRL  R2,8              Shift count for looping
       MOV  @CCPADR,R4        Get start address to fill
       MOVB R0,R1             Put filler in place for PUTV
FILSZ5 BL   @PUTV1            Put out a filler
       INC  R4                Increment filler position
       DEC  R2                One less to fill
       JNE  FILSZ5            Loop if move
       MOVB R2,@MNUM1         Restore for GPL
       JMP  CSTR07
* LLIST
* R0 - FAC - address of keytab in GROM
* R1 - keyword length
LLIST  MOV  R11,R12           Save return address
       BL   @PUTSTK           Save GROM address
       MOV  @FAC,R0           Get address of keytab
       MOVB @CHAT,R8          Get token to search for
       LI   R1,1              Assume one character keyword
LLISZ4 MOVB R0,@GRMWAX(R13)   Load GROM address of table
       MOVB @R0LB,@GRMWAX(R13) Both bytes
       MOVB *R13,R3           Read address of x-char table
       MOVB *R13,@R3LB        Both bytes
LLISZ5 A    R1,R3             Add length of keyword to point
*                              at token
       MOVB R3,@GRMWAX(R13)   Write out new GROM address
       MOVB @R3LB,@GRMWAX(R13) Which points to token
       MOVB *R13,R4           Read token value
       MOVB *R13,R5           Read possible end of x-char
*                              table
       CB   R4,R8             Token value match?
       JEQ  LLISZ6            Yes!!! Found the keyword
       INC  R3                No, so skip token value
       CB   R5,@CCBHFF        Reach end of x-char table?
       JNE  LLISZ5            No, so check more in the table
       INCT R0                Point into x+1 char table
       INC  R1                Try x+1 char table
       JMP  LLISZ4            Loop to check it
* Come here when found keyword
LLISZ6 S    R1,R3             Subtract length to pnt at K.W.
       MOV  R3,@FAC8          Save ptr to KeyWord for GPL
       MOV  R1,@FAC4          Save KeyWord length for GPL
       MOVB R8,@FAC           Save CHAT for GPL
       BL   @GETSTK           Restore GROM addres
       B    *R12              And return to GPL
********************************************************************************
       AORG >7C56
       TITL 'SCANS'
 
RETURZ EQU  >88
DEFZ   EQU  >89
DIMZ   EQU  >8A
ENDZ   EQU  >8B
FORZ   EQU  >8C
INPUTZ EQU  >92
DATAZ  EQU  >93
REMZ   EQU  >9A
ONZ    EQU  >9B
CALLZ  EQU  >9D
OPTIOZ EQU  >9E
IMAGEZ EQU  >A3
SUBXTZ EQU  >A7
SUBNDZ EQU  >A8
LINPUZ EQU  >AA
STEPZ  EQU  >B2
NUMZ   EQU  >C7
*-----------------------------------------------------------*
* Added for "NOPSCAN" feature 6/8/81                        *
P1     EQU  >40               @
P2     EQU  >50               P
P3     EQU  >2B               +
P4     EQU  >2D               -
P5     EQU  >70               p
PSCFG  EQU  >03B7             VDP temporary: PSCAN flag
*                                            >00 : no pscan *
*                                            >FF : pscan    *
*-----------------------------------------------------------*
 
*-----------------------------------------------------------*
* SCAN routine is changed for implementing "NOPSCAN"        *
* feature,                    6/8/81                        *
* "!@P+" or "!@p+"            is RESUME PSCAN               *
* "!@P-" or "!@p-"            is NO PSCAN                   *
*-----------------------------------------------------------*
*                                                           *
*************************************************************
* SCAN is the main looping structure of the prescan routine.*
* Takes care of scanning each statement in a line. Goes     *
* back to GPL to scan the special cases (DEF, OPTION, DIM,  *
* SUB, CALL, SUBEND, SUBEXIT) and also goes to GPL to enter *
* variables into the symbol table. All statements which are *
* not allowed to be imperative are checked directly without *
* goting to GPL. The NOCARE label is where a non-special    *
* statement is scanned, looking for variables to enter them *
* into the symbol table.                                    *
*************************************************************
PSCAN  MOVB *R13,R0           Read Scan code
       BL   @PUTSTK           Save GROM address
       BL   @SETREG           Set up R8/R9 with CHAT/SUBSTK
* First decode the type of XML being executed
* Types are: >00 - initial call with program
*            >01 - resume within a statement after call to
*                  GPL for some reason
*            >02 - initial call for imperative statement
       SRL  R0,8              Set condition
       JEQ  SCAN05            If calling scan routine w/pgm
       DEC  R0                Returning from call to GPL?
       JEQ  JNCARE            Yes, continue w/in line
       MOV  *R9,@RTNADD
       JMP  SCAN10
SCAN05 A    @C3,*R9           Skip following XML and select
       MOV  *R9,@RTNADD       Set up rtn to common GPL loc
       CLR  @DATA             Assume out of data
SCAN5A C    @LINUM,@EXTRAM    End of program yet?
       JNE  SCAN07            No, get next line
SCAN5B MOVB @FORNET,R0        Check fornext counter
       JNE  FNERR             For/Next error
       MOVB @XFLAG,R0         Check subprogram bits
CBH40  EQU  $+1
       SLA  R0,4              Subprogram encountered?
       JLT  SCAN6A            Yes, check subend
SCAN06 LI   R0,>A000          Initialize data stack
       MOVB R0,@STACK
       BL   @RESOLV           Resolve any subprogram refs
       B    @GPL05            Return
SCAN6A SLA  R0,4              Subend encountered?
       JNC  ERRMS             No, text ended w/out subend
       LI   R3,TABSAV         Get main symbol table's ptr
       BL   @GET1             Get it
       MOV  R1,@SYMTAB
       JMP  SCAN06            Merge back in
ERRMS  LI   R3,>18            * MISSING SUBEND
       JMP  GPL05L
SCAN07 S    @C4,@EXTRAM       Go to next line in program
       MOVB @RAMTOP,R0        ERAM program?
       JNE  SCAN08            Yes, handle  ERAM
       BL   @GET              No, het new line pointer in VDP
       DATA EXTRAM
       JMP  SCAN09
SCAN08 BL   @GETG             Get new line pointer from GRAM
       DATA EXTRAM
SCAN09 MOV  R1,@PGMPTR        Put new line pointer into perm
       SZCB @CBH40,@XFLAG     Reset IFFLAG only on new line
*-----------------------------------------------------------*
* Following is changed for adding "nopscan" feature         *
* SCAN9A @PGMCHR                Get 1st token on line       *
SCAN9A BL   @PGMCHR           Get 1st token on line         *
       LI   R3,PSCFG          Check the flag to see which   *
*                  mode is in: NOPSCAN (>00) or PSCAN (>FF) *
       BL   @GETV1            Get the flag from VDP         *
       JEQ  NPSCAN            NOPSCAN mode                  *
*-----------------------------------------------------------*
       SZCB @CBH94,@XFLAG     Reset ENTER, STRFLG, and FNCFLG
       MOVB @XFLAG,R0         Get flag bits
       SLA  R0,8              Shift to check REMODE
       JNC  SCAN10            If not in REMODE
       MOVB R8,R8             Check if token
       JLT  SCAN11            If token, look further
ERRIBS LI   R3,>1E            * ILLEGAL BETWEEN SUBPROGRAMS
       JMP  GPL05L            Goto error return
SCAN11 SETO R6                Set up index into table
SCAN12 INC  R6                Increment to 1st/next element
       CB   R8,@IBSTAB(R6)    legal stmt between subprogdams?
       JH   SCAN12            Not able to tell, check further
       JL   ERRIBS            Illegal statement here
SCAN10 CLR  R6                Offset into special stmt table
SCAN15 MOV  @SCNTAB(R6),R3    Read entry from special table
       CB   R3,R8             Match this token?
       JEQ  SCAN20            Yes, handle special case
       JH   NOCARE            Didn't match but passed in tab
       INCT R6                Increment offset into table
       CI   R6,TABLEN         Reach end of table?
       JNE  SCAN15            No, check further
JNCARE JMP  NOCARE            End of table, not special case
SCAN20 SLA  R3,8              Look at special case byte
       JLT  SCGPL1            If MSB set, goto GPL
       SWPB R3                MSB reset, offset into 9900
       B    @OFFSET(R3)       Branch to 9900 special handler
SCGPL1 B    @SCNGPL
FNERR  B    @FNNERR
*-----------------------------------------------------------*
* These are added for "nopscan" feature 6/8/81              *
SCAN26 MOVB @PRGFLG,R0        In program mode?              *
       JEQ  SCAN5B            No, check for/next subs&rtn   *
SCAN28 BL   @PGMCHR           Yes, check "!@P+" or "!@P-"   *
       CI   R8,P1*256         "@" following "!"?            *
       JNE  SCAN5A            No, goto the next line        *
       BL   @PGMCHR           Yes, check for "P"            *
       CI   R8,P2*256                                       *
       JEQ  SCAN40            Yes, check for "+" or "-"     *
       CI   R8,P5*256         No, try "p"                   *
       JNE  SCAN5A            No, goto the next line        *
SCAN40 BL   @PGMCHR           Yes, check for "+" or "-"     *
       CI   R8,P3*256                                       *
       JEQ  SCAN35            "!@P+" is found at the        *
*                               beginnning of the line      *
       CI   R8,P4*256                                       *
       JNE  SCAN5A            Didn't file what we want,     *
*                              goto the next line           *
       LI   R1,0              "!@P-" is found, set flag to  *
*                              0 NO PSCAN                   *
SCAN30 LI   R4,PSCFG          Address register for PUTV1    *
       BL   @PUTV1            Set the flag PSCFG in VDP tem.*
       JMP  SCAN5A            Goto the next line            *
SCAN35 LI   R1,>FF00          "!@P+", set flag to be >FF so *
*                              RESUME PSCAN                 *
       JMP  SCAN30            Use common code to set flag   *
*-----------------------------------------------------------*
*-----------------------------------------------------------*
* In NOPSCAN mode, only looking for "!@P+", "!@P-" at the   *
* beginning of each line      6/8/81                        *
NPSCAN CI   R8,TREMZ*256      First token on line           *
*                              is it "!"                    *
       JEQ  SCAN28            Yes, check "!@P+" or "!@P-"   *
       B    @SCAN5A           No, ignore the whole line,    *
*                              just goto the next line      *
*-----------------------------------------------------------*
OFFSET
SCN26A JMP  SCAN26
SCAN25 MOVB @PRGFLG,R0        In imperative mode?
       JEQ  SCAN5C            Yes, check for/next sub & rtn
       B    @SCAN5A           No, check next line
SCAN5C B    @SCAN5B
* 9900 code special handlers
IFIF   SOCB @CBH40,@XFLAG     Indicate scan of "IF" stmt
* Special handler for program-only statements
IMPER  MOVB @PRGFLG,R0        Executing in a program?
       JNE  NXTCHR            Yes, proceed in don't char mode
ERRIMP LI   R3,>12            Illegal imperative return code
GPL05L JMP  GPL05             Return to GPL with error
* Special handler for data-statements
DATA1  MOVB @DATA,R0          Data already encountered?
       JNE  IMAGE             Yes, don't set pointer
       MOV  @EXTRAM,@LNBUF    Save line buffer pointer
       MOV  @PGMPTR,@DATA     Set line buffer pointer
* Special handler for image-statements
IMAGE  MOVB @PRGFLG,R0        In program mode?
       B    @SCAN5A           Yes, no need to scan line
       JMP  ERRIMP            No, illegal imperative
* Special handler for for-statements
FOR    INC  @XFLAG            Increment the nesting counter
       MOVB @XFLAG,R0         Fetch the IFFLAG
       ANDI R0,>4000          Inside an if-statement?
       JEQ  NXTCHR            No, continue in don't care mode
SNTXER LI   R3,>1A            * SYNTAX ERROR
       JMP  GPL05
* Special handler for next-statements
SNEXT  MOV  @XFLAG,R0         Get flag and for-next counter
       ANDI R0,>40FF          Get rid of flag bits except IF
       MOVB R0,R0             IFFLAG set?
       JNE  SNTXER            Yes, syntax error
       DEC  R0                Decrement counter by one
       MOVB @R0LB,@FORNET     Move back to the real conter
       JEQ  NXTCHR            Returning to top level, ok
       JGT  NXTCHR            Still at a secndary level, ok
       LI   R3,>14            For/next nesting return code
       JMP  GPL05             Return to GPL with error
ELSE   MOVB @XFLAG,R0         Get flag byte
       ANDI R0,>4000          Inside an if?
       JEQ  SNTXER            No, error
* Special handler for statement seperator
SEPSMT B    @SCAN9A           Skip the '::' and check next
* General don't care scan. Simply looks for variables to
*  enter into symbol table; stops on end of statement
NOCARE CI   R8,SSEPZ*256      At a statement separator
       JEQ  SEPSMT            Skip and scan next statement
       CI   R8,TREMZ*256      At a tail remark?
       JEQ  SCAN25            Yes, check mode
       MOVB R8,R8             At an end-of-line or symbol?
       JEQ  SCAN25            EOL, checK mode
       JGT  ENTER             Symbol, ENTER in symbol table
       CI   R8,LNZ*256        Special line number token?
       JEQ  SKIPLN            Yes, need to skip it
       CI   R8,NUMZ*256       Special numeric token?
       JEQ  STRSKP            Yes, need to skip it
       CI   R8,UNQSTZ*256     Special string token?
       JEQ  STRSKP            Yes, need to skip it
       CI   R8,THENZ*256      Hit a then-clause?
       JEQ  ELSE              Yes, treat like a stmt-sep
       CI   R8,ELSEZ*256      Hit a else-clause?
       JEQ  ELSE              Yes, t[eat liek a stmt-sep
NXTCHR BL   @PGMCHR           Get next token
       JMP  NOCARE            And continue loop
SKIPLN INCT @PGMPTR           Skip line number
       JMP  NXTCHR            And get next token
STRSKP BL   @PGMCHR           Get length of string/number
       SWPB R8                Swap for add
       A    R8,@PGMPTR        Skip the string of number
       CLR  R8                Clear LSB of character
       JMP  NXTCHR            And get next token
* Code to return to GPL to handle special case or an
*  end-of-line return
FNNERR LI   R3,>16            FOR/NEXT NESTING
       JMP  GPL05
ENTER  LI   R3,>10            Load return code for ENTER
       JMP  GPL05             Goto GPL
SCNGPL ANDI R3,>7F00          Throw away GPL flag
       SRL  R3,8              Shift to use as index for rtn
GPL05  MOV  @RTNADD,*R9       Make sure right GROM address
       A    R3,*R9            Add offset to old GROM address
       BL   @SAVREG           Save R8/R9 in CHAT/SUBSTK
       BL   @GETSTK           Restore old GROM address
       B    @RESET            Goto GPL w/condition reset
*************************************************************
* Table of specially scanned statements                     *
* 2 bytes / special token                                   *
* Byte 1 - token value                                      *
* Byte 2 - "address" of special handler                     *
*        If MSB set then GPL and rest is offset from        *
*         the XML that got us here                          *
*        If MSB reset then 9900 code and is offset from     *
*         label OFFSET in this assembly of the special      *
*         case handler                                      *
*************************************************************
SCNTAB BYTE ELSEZ,ELSE-OFFSET
       BYTE SSEPZ,SEPSMT-OFFSET
*-----------------------------------------------------------*
* Change the following line for searching for !@P- at the   *
*  beginning of line                                        *
*      BYTE TREMZ,SCAN25-OFFSET                             *
       BYTE TREMZ,SCN26A-OFFSET
*-----------------------------------------------------------*
       BYTE IFZ,IFIF-OFFSET
       BYTE GOZ,IMPER-OFFSET
       BYTE GOTOZ,IMPER-OFFSET
       BYTE GOSUBZ,IMPER-OFFSET
       BYTE RETURZ,IMPER-OFFSET
       BYTE DEFZ,>82
       BYTE DIMZ,>84
       BYTE FORZ,FOR-OFFSET
       BYTE INPUTZ,IMPER-OFFSET
       BYTE DATAZ,DATA1-OFFSET
       BYTE NEXTZ,SNEXT-OFFSET
       BYTE REMZ,SCAN25-OFFSET
       BYTE ONZ,IMPER-OFFSET
       BYTE CALLZ,>86
       BYTE OPTIOZ,>88
       BYTE SUBZ,>8A
       BYTE IMAGEZ,IMAGE-OFFSET
       BYTE SUBXTZ,>8C
       BYTE SUBNDZ,>8E
       BYTE LINPUZ,IMPER-OFFSET
       BYTE THENZ,ELSE-OFFSET
TABLEN EQU  $-SCNTAB
IBSTAB BYTE SSEPZ
       BYTE TREMZ
       BYTE ENDZ
       BYTE REMZ
       BYTE SUBZ
       BYTE >FF
********************************************************************************
       AORG >7EA6
       TITL 'GREADS'

* (RAM to RAM)
* Read data from ERAM 
* @GSRC  : Source address on ERAM
* @DEST  : Destination address in CPU
*           Where the data stored after read from ERAM
* @BCNT3 : byte count
GREAD1 LI   R3,BCNT3          # of bytes to move
       LI   R2,GSRC           Source in ERAM
       LI   R1,DEST           Destination in CPU
       JMP  GRZ1              Jump to common routine
* Read data from ERAM to CPU
* @ADDR1 : Source address on ERAM
* @ADDR2 : Destination address in CPU
*           Where the data stored after read from ERAM
* @BCNT1 : byte count
GREAD  LI   R3,BCNT1          # of bytes to move
       LI   R2,ADDR1          Source in ERAM
       LI   R1,ADDR2          Destination in CPU
* Common ERAM to CPU transfer routine
GRZ1   MOV  *R2,R4
GRZ2   MOVB *R4+,*R1+         Move byte from ERAM to CPU
       DEC  *R3               One less to move, done?
       JNE  GRZ2              No, copy the rest
       RT
********************************************************************************
 
       AORG >7ECA
       TITL 'GWRITES'
 
* (RAM to RAM) 
* Write the data whcih is stored in CPU to ERAM
* @GDST  : Destination address on ERAM where data is going
*           to be stored
* @CSRC  : Soruce address on CPU where data stored
* @BCNT2 : byte count
GWITE1 LI   R3,BCNT2          Count
       LI   R2,GDST           Destination
       LI   R1,CSRC           Source
       JMP  GWZ1
* Write the data which is stored in CPU to ERAM
* @ADDR1 : Destination address on ERAM where data is going
*           to be stroed
* @ADDR2 : Source address on CPU where dta is stored
* @BCNT1 : byte count
GWRITE LI   R3,BCNT1          Count
       LI   R2,ADDR1          Destination
       LI   R1,ADDR2          Source
* Common routine to copy from CPU to ERAM
GWZ1   EQU  $
       MOV  *R2,R4            Get distination address
       MOV  *R1,R1            Get CPU RAM address
       AI   R1,PAD0           Add in CPU offset
GWZ2   MOVB *R1+,*R4+         Move a byte
       DEC  *R3               One less to move, done?
       JNE  GWZ2              No, more to move
       RT
********************************************************************************
  
       AORG >7EF4
       TITL 'DELREPS'
 
* Delete the text in crunched program on VDP or ERAM
*  point to the line # (to be deleted) in the line # table
* RAMTOP  0 if no ERAM
* ENLN    Last location used by the line # table
* STLN    First location used by the line # table
*
 
DELREP MOV  R11,R8            Save return
       INCT @EXTRAM           Point to line ptr in table
       MOV  @EXTRAM,R3        Prepare to read it
       MOV  @RAMTOP,R7        Check ERAM flag & get in reg
       JNE  DE01              ERAM, get from it
       BL   @GET1             Get line ptr from VDP
       JMP  DE02
DE01   BL   @GETG2            Get line ptr from ERAM
DE02   DEC  R1                Point to line length
       MOV  R1,R3             Prepare to read length
       MOV  R1,R9             Save copy for use later
       MOV  R7,R7             Editing in ERAM?
       JNE  DE03              ERAM, get length from it
       BL   @GETV1            Get line length from VDP
       JMP  DE04
DE03   MOVB *R3,R1
DE04   MOVB R1,R2             Move text length for use
       SRL  R2,8              Need as a word
       INC  R2                Text length = length + length
*                              byte
       MOV  @ENLN,R3          Get end of line # table
       INC  R3                Adjust for inside loop
* UPDATE THE LINE # TABLE
DEREA  DECT R3                Point to line pointer
       MOV  R7,R7             Editing in ERAM?
       JNE  DE05              ERAM, read it as such
       BL   @GET1             Get line pointer from VDP
       JMP  DE06
DE05   BL   @GETG2            Get line pointer from ERAM
DE06   MOV  R1,R5             Move for use
       DEC  R5                Point to length byte
       C    R9,R5             Compare location of delete
*                              line & this line
       JLE  DEREB             This line won't move ,
*                              don't fix pointer
       A    R2,R1             Add distance to move to pointer
       MOV  R3,R4             Write it to same place
       MOV  R7,R7             Editing in ERAM?
       JNE  DE10              Yes
       BL   @PUT1             Put back into line # table
       JMP  DEREB
DE10   BL   @PUTG2            Put back into line # table
DEREB  DECT R3                Point at the line #
       C    R3,@STLN          At last line in table?
       JNE  DEREA             No, loop for more
* UPDATA OF LINE # TABLE IS COMPLETE, NOW DELETE TEXT
* R9 still contains pointer to length byte of text to delete
* R2 still contains text length
       DEC  R9
       MOV  R9,R3
       MOV  R9,R5
       A    R2,R5             Point to 1st token
       MOV  R3,R1             Save for later use
       S    @STLN,R1          VDP, calculate # of bytes to move
       INC  R1                Correct offset by one
       BL   @MVDN2            Delete the text
* NOW SET UP POINTERS TO LINE TABLE
DE18   LI   R1,EXTRAM         Start with EXTRAM
       A    R2,*R1+           Update EXTRAM
       A    R2,*R1+           Update STLN
       A    R2,*R1            Update ENLN
       B    *R8               And return
********************************************************************************
       AORG >7F7E
       TITL 'MVDNS'

* (VDP to VDP) or (RAM to RAM) 
* WITHOUT ERAM : Move the contents in VDP RAM from a lower
*                address to a higher address avoiding a
*                possible over-write of data
* >835C          ARG    : byte count
* >8300          VAR0   : source address
* >8306          VARY2  : destination address
* WITH ERAM    Same as above except moves ERAM to ERAM
 
MVDN   MOV  @ARG,R1           Get byte count
       MOV  @VARY2,R5         Get destination
       MOV  @VAR0,R3          Get source
MVDN2  MOV  @RAMTOP,R7        ERAM or VDP?
       JNE  MV01              ERAM, so handle it
       JMP  MV05              VDP, so jump into loop
MVDN1  DEC  R5
       DEC  R3
MV05   EQU  $
       MOVB @R3LB,*R15        Write out read address
       MOVB R3,*R15
       MOVB @XVDPRD,R7        Read a byte
       MOVB @R5LB,*R15        Write out write address
       ORI  R5,WRVDP          Enable VDP write
       MOVB R5,*R15
       MOVB R7,@XVDPWD        Write the byte
       DEC  R1                One less byte to move
       JNE  MVDN1             Loop if more to move
       RT
MV01   EQU  $
MVDNZ1 MOVB *R3,*R5           Move a byte
       DEC  R3                Decrement destination
       DEC  R5                Decrement source
       DEC  R1                One less byte to move
       JNE  MVDNZ1            Loop if more to move
       RT
********************************************************************************
 
       AORG >7FC0
       TITL 'VGWITES'

* (VDP to RAM) >834C=ADDR1,>8350=ADDR2,>834E=BCNT1
* Move data from VDP to ERAM
* @ADDR1 : Source address where the data stored on VDP
* @ADDR2 : Destination address on ERAM
* @BCNT1 : byte count
 
VGWITE EQU  $
       MOVB @ADDR11,*R15      LSB of VDP address
       MOV  @ADDR2,R2         Address in ERAM
       MOVB @ADDR1,*R15       MSB of VDP address
       NOP
VGZ1   MOVB @XVDPRD,*R2+      Move a byte
       DEC  @BCNT1            One less to move
       JNE  VGZ1              If not done, loop for more
       RT                     Return
********************************************************************************
 
       AORG >7FDA
       TITL 'GVWITES'
 
* Move data from ERAM to VDP (RAM to VDP)
* @GSRC  : Source address where the data stored on ERAM
* @DEST  : Destination address on VDP
* @BCNT3 : byte count
 
GVWITE MOV  @DEST,R2          VDP address
       MOVB @R2LB,*R15        LSB of VDP address
       ORI  R2,WRVDP          Enable VDP write
       MOVB R2,*R15           MSB of VDP address
       MOV  @GSRC,R3          ERAM address
GVZ1   MOVB *R3+,@XVDPWD      Move a byte
       DEC  @BCNT3            One less to move
       JNE  GVZ1              If not done, loop for more
       RT                     Return
********************************************************************************
       AORG >7FFA
PAGER  CLR  @>6000      * RESTORE PAGE ONE
       B    *R9
********************************************************************************
 
       END
 
